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

-- | @futhark autotune@
module Futhark.CLI.Autotune (main) where

import Control.Monad
import qualified Data.ByteString.Char8 as SBS
import Data.Function (on)
import Data.List (elemIndex, intersect, isPrefixOf, minimumBy, sort, sortOn)
import Data.Maybe
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Tree
import Futhark.Bench
import Futhark.Server
import Futhark.Test
import Futhark.Util (maxinum)
import Futhark.Util.Options
import System.Environment (getExecutablePath)
import System.Exit
import System.FilePath
import System.Process
import Text.Read (readMaybe)
import Text.Regex.TDFA

data AutotuneOptions = AutotuneOptions
  { AutotuneOptions -> String
optBackend :: String,
    AutotuneOptions -> Maybe String
optFuthark :: Maybe String,
    AutotuneOptions -> Int
optRuns :: Int,
    AutotuneOptions -> Maybe String
optTuning :: Maybe String,
    AutotuneOptions -> [String]
optExtraOptions :: [String],
    AutotuneOptions -> Int
optVerbose :: Int,
    AutotuneOptions -> Int
optTimeout :: Int,
    AutotuneOptions -> Int
optDefaultThreshold :: Int
  }

initialAutotuneOptions :: AutotuneOptions
initialAutotuneOptions :: AutotuneOptions
initialAutotuneOptions =
  String
-> Maybe String
-> Int
-> Maybe String
-> [String]
-> Int
-> Int
-> Int
-> AutotuneOptions
AutotuneOptions String
"opencl" Maybe String
forall a. Maybe a
Nothing Int
10 (String -> Maybe String
forall a. a -> Maybe a
Just String
"tuning") [] Int
0 Int
60 Int
thresholdMax

compileOptions :: AutotuneOptions -> IO CompileOptions
compileOptions :: AutotuneOptions -> IO CompileOptions
compileOptions AutotuneOptions
opts = do
  String
futhark <- IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getExecutablePath String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO String) -> Maybe String -> IO String
forall a b. (a -> b) -> a -> b
$ AutotuneOptions -> Maybe String
optFuthark AutotuneOptions
opts
  CompileOptions -> IO CompileOptions
forall (m :: * -> *) a. Monad m => a -> m a
return (CompileOptions -> IO CompileOptions)
-> CompileOptions -> IO CompileOptions
forall a b. (a -> b) -> a -> b
$
    CompileOptions :: String -> String -> [String] -> CompileOptions
CompileOptions
      { compFuthark :: String
compFuthark = String
futhark,
        compBackend :: String
compBackend = AutotuneOptions -> String
optBackend AutotuneOptions
opts,
        compOptions :: [String]
compOptions = [String]
forall a. Monoid a => a
mempty
      }

runOptions :: Int -> AutotuneOptions -> RunOptions
runOptions :: Int -> AutotuneOptions -> RunOptions
runOptions Int
timeout_s AutotuneOptions
opts =
  RunOptions :: Int -> Int -> Int -> Maybe (Int -> IO ()) -> RunOptions
RunOptions
    { runRuns :: Int
runRuns = AutotuneOptions -> Int
optRuns AutotuneOptions
opts,
      runTimeout :: Int
runTimeout = Int
timeout_s,
      runVerbose :: Int
runVerbose = AutotuneOptions -> Int
optVerbose AutotuneOptions
opts,
      runResultAction :: Maybe (Int -> IO ())
runResultAction = Maybe (Int -> IO ())
forall a. Maybe a
Nothing
    }

type Path = [(String, Int)]

regexGroups :: Regex -> String -> Maybe [String]
regexGroups :: Regex -> String -> Maybe [String]
regexGroups Regex
regex String
s = do
  (String
_, String
_, String
_, [String]
groups) <-
    Regex -> String -> Maybe (String, String, String, [String])
forall regex source target (m :: * -> *).
(RegexContext regex source target, MonadFail m) =>
regex -> source -> m target
matchM Regex
regex String
s :: Maybe (String, String, String, [String])
  [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
groups

comparisons :: String -> [(String, Int)]
comparisons :: String -> [(String, Int)]
comparisons = (String -> Maybe (String, Int)) -> [String] -> [(String, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (String, Int)
forall {b}. Read b => String -> Maybe (String, b)
isComparison ([String] -> [(String, Int)])
-> (String -> [String]) -> String -> [(String, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
  where
    regex :: Regex
regex = String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
source -> regex
makeRegex (String
"Compared ([^ ]+) <= (-?[0-9]+)" :: String)
    isComparison :: String -> Maybe (String, b)
isComparison String
l = do
      [String
thresh, String
val] <- Regex -> String -> Maybe [String]
regexGroups Regex
regex String
l
      b
val' <- String -> Maybe b
forall a. Read a => String -> Maybe a
readMaybe String
val
      (String, b) -> Maybe (String, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
thresh, b
val')

type RunDataset = Int -> Path -> IO (Either String ([(String, Int)], Int))

type DatasetName = String

serverOptions :: Path -> AutotuneOptions -> [String]
serverOptions :: [(String, Int)] -> AutotuneOptions -> [String]
serverOptions [(String, Int)]
path AutotuneOptions
opts =
  String
"--default-threshold" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
  Int -> String
forall a. Show a => a -> String
show (AutotuneOptions -> Int
optDefaultThreshold AutotuneOptions
opts) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
  String
"-L" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
  ((String, Int) -> String) -> [(String, Int)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Int) -> String
forall {a}. Show a => (String, a) -> String
opt [(String, Int)]
path
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ AutotuneOptions -> [String]
optExtraOptions AutotuneOptions
opts
  where
    opt :: (String, a) -> String
opt (String
name, a
val) = String
"--size=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
val

prepare :: AutotuneOptions -> FutharkExe -> FilePath -> IO [(DatasetName, RunDataset, T.Text)]
prepare :: AutotuneOptions
-> FutharkExe -> String -> IO [(String, RunDataset, Text)]
prepare AutotuneOptions
opts FutharkExe
futhark String
prog = do
  ProgramTest
spec <- String -> IO ProgramTest
testSpecFromFileOrDie String
prog
  CompileOptions
copts <- AutotuneOptions -> IO CompileOptions
compileOptions AutotuneOptions
opts

  [InputOutputs]
truns <-
    case ProgramTest -> TestAction
testAction ProgramTest
spec of
      RunCases [InputOutputs]
ios [StructureTest]
_ [WarningTest]
_ | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [InputOutputs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InputOutputs]
ios -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AutotuneOptions -> Int
optVerbose AutotuneOptions
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
"Entry points:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (InputOutputs -> String) -> [InputOutputs] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String)
-> (InputOutputs -> Text) -> InputOutputs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputOutputs -> Text
iosEntryPoint) [InputOutputs]
ios)

        Either (String, Maybe ByteString) ()
res <- Maybe Int
-> CompileOptions
-> String
-> [InputOutputs]
-> IO (Either (String, Maybe ByteString) ())
forall (m :: * -> *).
MonadIO m =>
Maybe Int
-> CompileOptions
-> String
-> [InputOutputs]
-> m (Either (String, Maybe ByteString) ())
prepareBenchmarkProgram Maybe Int
forall a. Maybe a
Nothing CompileOptions
copts String
prog [InputOutputs]
ios
        case Either (String, Maybe ByteString) ()
res of
          Left (String
err, Maybe ByteString
errstr) -> do
            String -> IO ()
putStrLn String
err
            IO () -> (ByteString -> IO ()) -> Maybe ByteString -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ByteString -> IO ()
SBS.putStrLn Maybe ByteString
errstr
            IO [InputOutputs]
forall a. IO a
exitFailure
          Right () ->
            [InputOutputs] -> IO [InputOutputs]
forall (m :: * -> *) a. Monad m => a -> m a
return [InputOutputs]
ios
      TestAction
_ ->
        String -> IO [InputOutputs]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported test spec."

  let runnableDataset :: Text -> TestRun -> Maybe (String, RunDataset)
runnableDataset Text
entry_point TestRun
trun =
        case TestRun -> ExpectedResult Success
runExpectedResult TestRun
trun of
          Succeeds Maybe Success
expected
            | [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TestRun -> [String]
runTags TestRun
trun [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [String
"notune", String
"disable"]) ->
              (String, RunDataset) -> Maybe (String, RunDataset)
forall a. a -> Maybe a
Just (TestRun -> String
runDescription TestRun
trun, Text -> TestRun -> Maybe Success -> RunDataset
run Text
entry_point TestRun
trun Maybe Success
expected)
          ExpectedResult Success
_ -> Maybe (String, RunDataset)
forall a. Maybe a
Nothing

  ([[(String, RunDataset, Text)]] -> [(String, RunDataset, Text)])
-> IO [[(String, RunDataset, Text)]]
-> IO [(String, RunDataset, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(String, RunDataset, Text)]] -> [(String, RunDataset, Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[(String, RunDataset, Text)]]
 -> IO [(String, RunDataset, Text)])
-> ((InputOutputs -> IO [(String, RunDataset, Text)])
    -> IO [[(String, RunDataset, Text)]])
-> (InputOutputs -> IO [(String, RunDataset, Text)])
-> IO [(String, RunDataset, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InputOutputs]
-> (InputOutputs -> IO [(String, RunDataset, Text)])
-> IO [[(String, RunDataset, Text)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [InputOutputs]
truns ((InputOutputs -> IO [(String, RunDataset, Text)])
 -> IO [(String, RunDataset, Text)])
-> (InputOutputs -> IO [(String, RunDataset, Text)])
-> IO [(String, RunDataset, Text)]
forall a b. (a -> b) -> a -> b
$ \InputOutputs
ios -> do
    let cases :: [(String, RunDataset)]
cases =
          (TestRun -> Maybe (String, RunDataset))
-> [TestRun] -> [(String, RunDataset)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text -> TestRun -> Maybe (String, RunDataset)
runnableDataset (Text -> TestRun -> Maybe (String, RunDataset))
-> Text -> TestRun -> Maybe (String, RunDataset)
forall a b. (a -> b) -> a -> b
$ InputOutputs -> Text
iosEntryPoint InputOutputs
ios) (InputOutputs -> [TestRun]
iosTestRuns InputOutputs
ios)
    [(String, RunDataset)]
-> ((String, RunDataset) -> IO (String, RunDataset, Text))
-> IO [(String, RunDataset, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, RunDataset)]
cases (((String, RunDataset) -> IO (String, RunDataset, Text))
 -> IO [(String, RunDataset, Text)])
-> ((String, RunDataset) -> IO (String, RunDataset, Text))
-> IO [(String, RunDataset, Text)]
forall a b. (a -> b) -> a -> b
$ \(String
dataset, RunDataset
do_run) ->
      (String, RunDataset, Text) -> IO (String, RunDataset, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dataset, RunDataset
do_run, InputOutputs -> Text
iosEntryPoint InputOutputs
ios)
  where
    run :: Text -> TestRun -> Maybe Success -> RunDataset
run Text
entry_point TestRun
trun Maybe Success
expected Int
timeout [(String, Int)]
path = do
      let bestRuntime :: ([RunResult], T.Text) -> ([(String, Int)], Int)
          bestRuntime :: ([RunResult], Text) -> ([(String, Int)], Int)
bestRuntime ([RunResult]
runres, Text
errout) =
            ( String -> [(String, Int)]
comparisons (Text -> String
T.unpack Text
errout),
              [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (RunResult -> Int) -> [RunResult] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map RunResult -> Int
runMicroseconds [RunResult]
runres
            )

          ropts :: RunOptions
ropts = Int -> AutotuneOptions -> RunOptions
runOptions Int
timeout AutotuneOptions
opts

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AutotuneOptions -> Int
optVerbose AutotuneOptions
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
"Running with options: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ([(String, Int)] -> AutotuneOptions -> [String]
serverOptions [(String, Int)]
path AutotuneOptions
opts)

      -- XXX: it is really inefficient to start a new server for every
      -- run, but unfortunately we can only set threshold parameters
      -- on startup.
      let progbin :: String
progbin = String
"." String -> String -> String
</> String -> String
dropExtension String
prog
      String
-> [String]
-> (Server -> IO (Either String ([(String, Int)], Int)))
-> IO (Either String ([(String, Int)], Int))
forall a. String -> [String] -> (Server -> IO a) -> IO a
withServer String
progbin ([(String, Int)] -> AutotuneOptions -> [String]
serverOptions [(String, Int)]
path AutotuneOptions
opts) ((Server -> IO (Either String ([(String, Int)], Int)))
 -> IO (Either String ([(String, Int)], Int)))
-> (Server -> IO (Either String ([(String, Int)], Int)))
-> IO (Either String ([(String, Int)], Int))
forall a b. (a -> b) -> a -> b
$ \Server
server ->
        (Text -> Either String ([(String, Int)], Int))
-> (([RunResult], Text) -> Either String ([(String, Int)], Int))
-> Either Text ([RunResult], Text)
-> Either String ([(String, Int)], Int)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String ([(String, Int)], Int)
forall a b. a -> Either a b
Left (String -> Either String ([(String, Int)], Int))
-> (Text -> String) -> Text -> Either String ([(String, Int)], Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (([(String, Int)], Int) -> Either String ([(String, Int)], Int)
forall a b. b -> Either a b
Right (([(String, Int)], Int) -> Either String ([(String, Int)], Int))
-> (([RunResult], Text) -> ([(String, Int)], Int))
-> ([RunResult], Text)
-> Either String ([(String, Int)], Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([RunResult], Text) -> ([(String, Int)], Int)
bestRuntime)
          (Either Text ([RunResult], Text)
 -> Either String ([(String, Int)], Int))
-> IO (Either Text ([RunResult], Text))
-> IO (Either String ([(String, Int)], Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Server
-> RunOptions
-> FutharkExe
-> String
-> Text
-> Values
-> Maybe Success
-> String
-> IO (Either Text ([RunResult], Text))
benchmarkDataset
            Server
server
            RunOptions
ropts
            FutharkExe
futhark
            String
prog
            Text
entry_point
            (TestRun -> Values
runInput TestRun
trun)
            Maybe Success
expected
            (String -> Text -> TestRun -> String
testRunReferenceOutput String
prog Text
entry_point TestRun
trun)

--- Benchmarking a program

data DatasetResult = DatasetResult [(String, Int)] Double
  deriving (Int -> DatasetResult -> String -> String
[DatasetResult] -> String -> String
DatasetResult -> String
(Int -> DatasetResult -> String -> String)
-> (DatasetResult -> String)
-> ([DatasetResult] -> String -> String)
-> Show DatasetResult
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DatasetResult] -> String -> String
$cshowList :: [DatasetResult] -> String -> String
show :: DatasetResult -> String
$cshow :: DatasetResult -> String
showsPrec :: Int -> DatasetResult -> String -> String
$cshowsPrec :: Int -> DatasetResult -> String -> String
Show)

--- Finding initial comparisons.

--- Extracting threshold hierarchy.

type ThresholdForest = Forest (String, Bool)

thresholdMin, thresholdMax :: Int
thresholdMin :: Int
thresholdMin = Int
1
thresholdMax :: Int
thresholdMax = Int
2000000000

-- | Depth-first list of thresholds to tune in order, and a
-- corresponding assignment of ancestor thresholds to ensure that they
-- are used.
tuningPaths :: ThresholdForest -> [(String, Path)]
tuningPaths :: ThresholdForest -> [(String, [(String, Int)])]
tuningPaths = (Tree (String, Bool) -> [(String, [(String, Int)])])
-> ThresholdForest -> [(String, [(String, Int)])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([(String, Int)]
-> Tree (String, Bool) -> [(String, [(String, Int)])]
forall {a}. [(a, Int)] -> Tree (a, Bool) -> [(a, [(a, Int)])]
treePaths [])
  where
    treePaths :: [(a, Int)] -> Tree (a, Bool) -> [(a, [(a, Int)])]
treePaths [(a, Int)]
ancestors (Node (a
v, Bool
_) [Tree (a, Bool)]
children) =
      (Tree (a, Bool) -> [(a, [(a, Int)])])
-> [Tree (a, Bool)] -> [(a, [(a, Int)])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([(a, Int)] -> a -> Tree (a, Bool) -> [(a, [(a, Int)])]
onChild [(a, Int)]
ancestors a
v) [Tree (a, Bool)]
children [(a, [(a, Int)])] -> [(a, [(a, Int)])] -> [(a, [(a, Int)])]
forall a. [a] -> [a] -> [a]
++ [(a
v, [(a, Int)]
ancestors)]

    onChild :: [(a, Int)] -> a -> Tree (a, Bool) -> [(a, [(a, Int)])]
onChild [(a, Int)]
ancestors a
v child :: Tree (a, Bool)
child@(Node (a
_, Bool
cmp) [Tree (a, Bool)]
_) =
      [(a, Int)] -> Tree (a, Bool) -> [(a, [(a, Int)])]
treePaths ([(a, Int)]
ancestors [(a, Int)] -> [(a, Int)] -> [(a, Int)]
forall a. [a] -> [a] -> [a]
++ [(a
v, Bool -> Int
t Bool
cmp)]) Tree (a, Bool)
child

    t :: Bool -> Int
t Bool
False = Int
thresholdMax
    t Bool
True = Int
thresholdMin

thresholdForest :: FilePath -> IO ThresholdForest
thresholdForest :: String -> IO ThresholdForest
thresholdForest String
prog = do
  [(String, [(String, Bool)])]
thresholds <-
    String -> [(String, [(String, Bool)])]
getThresholds
      (String -> [(String, [(String, Bool)])])
-> IO String -> IO [(String, [(String, Bool)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess (String
"." String -> String -> String
</> String -> String
dropExtension String
prog) [String
"--print-sizes"] String
""
  let root :: (a, b) -> ((a, Bool), [a])
root (a
v, b
_) = ((a
v, Bool
False), [])
  ThresholdForest -> IO ThresholdForest
forall (m :: * -> *) a. Monad m => a -> m a
return (ThresholdForest -> IO ThresholdForest)
-> ThresholdForest -> IO ThresholdForest
forall a b. (a -> b) -> a -> b
$
    (((String, Bool), [String])
 -> ((String, Bool), [((String, Bool), [String])]))
-> [((String, Bool), [String])] -> ThresholdForest
forall b a. (b -> (a, [b])) -> [b] -> [Tree a]
unfoldForest ([(String, [(String, Bool)])]
-> ((String, Bool), [String])
-> ((String, Bool), [((String, Bool), [String])])
forall {a} {a} {b} {b}.
Ord a =>
[(a, [(a, b)])] -> ((a, b), [a]) -> ((a, b), [((a, b), [a])])
unfold [(String, [(String, Bool)])]
thresholds) ([((String, Bool), [String])] -> ThresholdForest)
-> [((String, Bool), [String])] -> ThresholdForest
forall a b. (a -> b) -> a -> b
$
      ((String, [(String, Bool)]) -> ((String, Bool), [String]))
-> [(String, [(String, Bool)])] -> [((String, Bool), [String])]
forall a b. (a -> b) -> [a] -> [b]
map (String, [(String, Bool)]) -> ((String, Bool), [String])
forall {a} {b} {a}. (a, b) -> ((a, Bool), [a])
root ([(String, [(String, Bool)])] -> [((String, Bool), [String])])
-> [(String, [(String, Bool)])] -> [((String, Bool), [String])]
forall a b. (a -> b) -> a -> b
$ ((String, [(String, Bool)]) -> Bool)
-> [(String, [(String, Bool)])] -> [(String, [(String, Bool)])]
forall a. (a -> Bool) -> [a] -> [a]
filter ([(String, Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(String, Bool)] -> Bool)
-> ((String, [(String, Bool)]) -> [(String, Bool)])
-> (String, [(String, Bool)])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [(String, Bool)]) -> [(String, Bool)]
forall a b. (a, b) -> b
snd) [(String, [(String, Bool)])]
thresholds
  where
    getThresholds :: String -> [(String, [(String, Bool)])]
getThresholds = (String -> Maybe (String, [(String, Bool)]))
-> [String] -> [(String, [(String, Bool)])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (String, [(String, Bool)])
findThreshold ([String] -> [(String, [(String, Bool)])])
-> (String -> [String]) -> String -> [(String, [(String, Bool)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    regex :: Regex
regex = String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
source -> regex
makeRegex (String
"(.*) \\(threshold\\(([^ ]+,)(.*)\\)\\)" :: String)

    findThreshold :: String -> Maybe (String, [(String, Bool)])
    findThreshold :: String -> Maybe (String, [(String, Bool)])
findThreshold String
l = do
      [String
grp1, String
_, String
grp2] <- Regex -> String -> Maybe [String]
regexGroups Regex
regex String
l
      (String, [(String, Bool)]) -> Maybe (String, [(String, Bool)])
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( String
grp1,
          ((String, Bool) -> Bool) -> [(String, Bool)] -> [(String, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((String, Bool) -> Bool) -> (String, Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool)
-> ((String, Bool) -> String) -> (String, Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Bool) -> String
forall a b. (a, b) -> a
fst) ([(String, Bool)] -> [(String, Bool)])
-> [(String, Bool)] -> [(String, Bool)]
forall a b. (a -> b) -> a -> b
$
            (String -> (String, Bool)) -> [String] -> [(String, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map
              ( \String
x ->
                  if String
"!" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x
                    then (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
x, Bool
False)
                    else (String
x, Bool
True)
              )
              ([String] -> [(String, Bool)]) -> [String] -> [(String, Bool)]
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
grp2
        )

    unfold :: [(a, [(a, b)])] -> ((a, b), [a]) -> ((a, b), [((a, b), [a])])
unfold [(a, [(a, b)])]
thresholds ((a
parent, b
parent_cmp), [a]
ancestors) =
      let ancestors' :: [a]
ancestors' = a
parent a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ancestors

          isChild :: (a, [(a, b)]) -> Maybe ((a, b), [a])
isChild (a
v, [(a, b)]
v_ancestors) = do
            b
cmp <- a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
parent [(a, b)]
v_ancestors
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$
              [a] -> [a]
forall a. Ord a => [a] -> [a]
sort (((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
forall a b. (a, b) -> a
fst [(a, b)]
v_ancestors)
                [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> [a]
forall a. Ord a => [a] -> [a]
sort (a
parent a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ancestors)
            ((a, b), [a]) -> Maybe ((a, b), [a])
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
v, b
cmp), [a]
ancestors')
       in ((a
parent, b
parent_cmp), ((a, [(a, b)]) -> Maybe ((a, b), [a]))
-> [(a, [(a, b)])] -> [((a, b), [a])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (a, [(a, b)]) -> Maybe ((a, b), [a])
forall {a} {b}. (a, [(a, b)]) -> Maybe ((a, b), [a])
isChild [(a, [(a, b)])]
thresholds)

--- Doing the atual tuning

tuneThreshold ::
  AutotuneOptions ->
  [(DatasetName, RunDataset, T.Text)] ->
  Path ->
  (String, Path) ->
  IO Path
tuneThreshold :: AutotuneOptions
-> [(String, RunDataset, Text)]
-> [(String, Int)]
-> (String, [(String, Int)])
-> IO [(String, Int)]
tuneThreshold AutotuneOptions
opts [(String, RunDataset, Text)]
datasets [(String, Int)]
already_tuned (String
v, [(String, Int)]
_v_path) = do
  Maybe (Int, Int)
tune_result <-
    (Maybe (Int, Int)
 -> (String, RunDataset, Text) -> IO (Maybe (Int, Int)))
-> Maybe (Int, Int)
-> [(String, RunDataset, Text)]
-> IO (Maybe (Int, Int))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Maybe (Int, Int)
-> (String, RunDataset, Text) -> IO (Maybe (Int, Int))
tuneDataset Maybe (Int, Int)
forall a. Maybe a
Nothing [(String, RunDataset, Text)]
datasets
  case Maybe (Int, Int)
tune_result of
    Maybe (Int, Int)
Nothing ->
      [(String, Int)] -> IO [(String, Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Int)] -> IO [(String, Int)])
-> [(String, Int)] -> IO [(String, Int)]
forall a b. (a -> b) -> a -> b
$ (String
v, Int
thresholdMin) (String, Int) -> [(String, Int)] -> [(String, Int)]
forall a. a -> [a] -> [a]
: [(String, Int)]
already_tuned
    Just (Int
_, Int
threshold) ->
      [(String, Int)] -> IO [(String, Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Int)] -> IO [(String, Int)])
-> [(String, Int)] -> IO [(String, Int)]
forall a b. (a -> b) -> a -> b
$ (String
v, Int
threshold) (String, Int) -> [(String, Int)] -> [(String, Int)]
forall a. a -> [a] -> [a]
: [(String, Int)]
already_tuned
  where
    tuneDataset :: Maybe (Int, Int) -> (DatasetName, RunDataset, T.Text) -> IO (Maybe (Int, Int))
    tuneDataset :: Maybe (Int, Int)
-> (String, RunDataset, Text) -> IO (Maybe (Int, Int))
tuneDataset Maybe (Int, Int)
thresholds (String
dataset_name, RunDataset
run, Text
entry_point) =
      if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (Text -> String
T.unpack Text
entry_point String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".") String
v
        then do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AutotuneOptions -> Int
optVerbose AutotuneOptions
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (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
v, String
"is irrelevant for", Text -> String
T.unpack Text
entry_point]
          Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, Int)
thresholds
        else do
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            [String] -> String
unwords
              [ String
"Tuning",
                String
v,
                String
"on entry point",
                Text -> String
T.unpack Text
entry_point,
                String
"and dataset",
                String
dataset_name
              ]

          Either String ([(String, Int)], Int)
sample_run <-
            RunDataset
run
              (AutotuneOptions -> Int
optTimeout AutotuneOptions
opts)
              ((String
v, Int -> ((Int, Int) -> Int) -> Maybe (Int, Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
thresholdMax (Int, Int) -> Int
forall a b. (a, b) -> b
snd Maybe (Int, Int)
thresholds) (String, Int) -> [(String, Int)] -> [(String, Int)]
forall a. a -> [a] -> [a]
: [(String, Int)]
already_tuned)

          case Either String ([(String, Int)], Int)
sample_run of
            Left String
err -> do
              -- If the sampling run fails, we treat it as zero information.
              -- One of our ancestor thresholds will have be set such that
              -- this path is never taken.
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AutotuneOptions -> Int
optVerbose AutotuneOptions
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (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
"Sampling run failed:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
              Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, Int)
thresholds
            Right ([(String, Int)]
cmps, Int
t) -> do
              let (Int
tMin, Int
tMax) = (Int, Int) -> Maybe (Int, Int) -> (Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Int
thresholdMin, Int
thresholdMax) Maybe (Int, Int)
thresholds
              let ePars :: [Int]
ePars =
                    Set Int -> [Int]
forall a. Set a -> [a]
S.toAscList (Set Int -> [Int]) -> Set Int -> [Int]
forall a b. (a -> b) -> a -> b
$
                      ((String, Int) -> Int) -> Set (String, Int) -> Set Int
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (String, Int) -> Int
forall a b. (a, b) -> b
snd (Set (String, Int) -> Set Int) -> Set (String, Int) -> Set Int
forall a b. (a -> b) -> a -> b
$
                        ((String, Int) -> Bool) -> Set (String, Int) -> Set (String, Int)
forall a. (a -> Bool) -> Set a -> Set a
S.filter ((Int, Int) -> (String, Int) -> Bool
candidateEPar (Int
tMin, Int
tMax)) (Set (String, Int) -> Set (String, Int))
-> Set (String, Int) -> Set (String, Int)
forall a b. (a -> b) -> a -> b
$
                          [(String, Int)] -> Set (String, Int)
forall a. Ord a => [a] -> Set a
S.fromList [(String, Int)]
cmps

                  runner :: Int -> Int -> IO (Maybe Int)
                  runner :: Int -> Int -> IO (Maybe Int)
runner Int
timeout' Int
threshold = do
                    Either String ([(String, Int)], Int)
res <- RunDataset
run Int
timeout' ((String
v, Int
threshold) (String, Int) -> [(String, Int)] -> [(String, Int)]
forall a. a -> [a] -> [a]
: [(String, Int)]
already_tuned)
                    case Either String ([(String, Int)], Int)
res of
                      Right ([(String, Int)]
_, Int
runTime) ->
                        Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> IO (Maybe Int)) -> Maybe Int -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
runTime
                      Either String ([(String, Int)], Int)
_ ->
                        Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing

              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AutotuneOptions -> Int
optVerbose AutotuneOptions
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
"Got ePars: " String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show [Int]
ePars)

              Int
newMax <- (Int -> Int -> IO (Maybe Int)) -> (Int, Int) -> [Int] -> IO Int
binarySearch Int -> Int -> IO (Maybe Int)
runner (Int
t, Int
tMax) [Int]
ePars
              let newMinIdx :: Maybe Int
newMinIdx = Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Int] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Int
newMax [Int]
ePars
              let newMin :: Int
newMin = [Int] -> Int
forall a (f :: * -> *). (Num a, Ord a, Foldable f) => f a -> a
maxinum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes [Int -> Maybe Int
forall a. a -> Maybe a
Just Int
tMin, Maybe Int
newMinIdx]
              Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Int, Int) -> IO (Maybe (Int, Int)))
-> Maybe (Int, Int) -> IO (Maybe (Int, Int))
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
newMin, Int
newMax)

    bestPair :: [(Int, Int)] -> (Int, Int)
    bestPair :: [(Int, Int)] -> (Int, Int)
bestPair = ((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> (Int, Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, Int) -> Int) -> (Int, Int) -> (Int, Int) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, Int) -> Int
forall a b. (a, b) -> a
fst)

    timeout :: Int -> Int
    -- We wish to let datasets run for the untuned time + 20% + 1 second.
    timeout :: Int -> Int
timeout Int
elapsed = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
elapsed Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1.2 :: Double) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

    candidateEPar :: (Int, Int) -> (String, Int) -> Bool
    candidateEPar :: (Int, Int) -> (String, Int) -> Bool
candidateEPar (Int
tMin, Int
tMax) (String
threshold, Int
ePar) =
      Int
ePar Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
tMin Bool -> Bool -> Bool
&& Int
ePar Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
tMax Bool -> Bool -> Bool
&& String
threshold String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v

    binarySearch :: (Int -> Int -> IO (Maybe Int)) -> (Int, Int) -> [Int] -> IO Int
    binarySearch :: (Int -> Int -> IO (Maybe Int)) -> (Int, Int) -> [Int] -> IO Int
binarySearch Int -> Int -> IO (Maybe Int)
runner best :: (Int, Int)
best@(Int
best_t, Int
best_e_par) [Int]
xs =
      case Int -> [Int] -> ([Int], [Int])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [Int]
xs of
        ([Int]
lower, Int
middle : Int
middle' : [Int]
upper) -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AutotuneOptions -> Int
optVerbose AutotuneOptions
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (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
"Trying e_par",
                  Int -> String
forall a. Show a => a -> String
show Int
middle,
                  String
"and",
                  Int -> String
forall a. Show a => a -> String
show Int
middle'
                ]
          Maybe Int
candidate <- Int -> Int -> IO (Maybe Int)
runner (Int -> Int
timeout Int
best_t) Int
middle
          Maybe Int
candidate' <- Int -> Int -> IO (Maybe Int)
runner (Int -> Int
timeout Int
best_t) Int
middle'
          case (Maybe Int
candidate, Maybe Int
candidate') of
            (Just Int
new_t, Just Int
new_t') ->
              if Int
new_t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
new_t'
                then -- recurse into lower half
                  (Int -> Int -> IO (Maybe Int)) -> (Int, Int) -> [Int] -> IO Int
binarySearch Int -> Int -> IO (Maybe Int)
runner ([(Int, Int)] -> (Int, Int)
bestPair [(Int
new_t, Int
middle), (Int, Int)
best]) [Int]
lower
                else -- recurse into upper half
                  (Int -> Int -> IO (Maybe Int)) -> (Int, Int) -> [Int] -> IO Int
binarySearch Int -> Int -> IO (Maybe Int)
runner ([(Int, Int)] -> (Int, Int)
bestPair [(Int
new_t', Int
middle'), (Int, Int)
best]) [Int]
upper
            (Just Int
new_t, Maybe Int
Nothing) ->
              -- recurse into lower half
              (Int -> Int -> IO (Maybe Int)) -> (Int, Int) -> [Int] -> IO Int
binarySearch Int -> Int -> IO (Maybe Int)
runner ([(Int, Int)] -> (Int, Int)
bestPair [(Int
new_t, Int
middle), (Int, Int)
best]) [Int]
lower
            (Maybe Int
Nothing, Just Int
new_t') ->
              -- recurse into upper half
              (Int -> Int -> IO (Maybe Int)) -> (Int, Int) -> [Int] -> IO Int
binarySearch Int -> Int -> IO (Maybe Int)
runner ([(Int, Int)] -> (Int, Int)
bestPair [(Int
new_t', Int
middle'), (Int, Int)
best]) [Int]
upper
            (Maybe Int
Nothing, Maybe Int
Nothing) -> do
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AutotuneOptions -> Int
optVerbose AutotuneOptions
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2) (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
"Timing failed for candidates",
                      Int -> String
forall a. Show a => a -> String
show Int
middle,
                      String
"and",
                      Int -> String
forall a. Show a => a -> String
show Int
middle'
                    ]
              Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
best_e_par
        ([Int]
_, [Int]
_) -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AutotuneOptions -> Int
optVerbose AutotuneOptions
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (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
"Trying e_pars", [Int] -> String
forall a. Show a => a -> String
show [Int]
xs]
          [(Int, Int)]
candidates <-
            [Maybe (Int, Int)] -> [(Int, Int)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Int, Int)] -> [(Int, Int)])
-> ([Maybe Int] -> [Maybe (Int, Int)])
-> [Maybe Int]
-> [(Int, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Maybe Int -> Maybe (Int, Int))
-> [Int] -> [Maybe Int] -> [Maybe (Int, Int)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((Int -> (Int, Int)) -> Maybe Int -> Maybe (Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> (Int, Int)) -> Maybe Int -> Maybe (Int, Int))
-> (Int -> Int -> (Int, Int))
-> Int
-> Maybe Int
-> Maybe (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> (Int, Int)) -> Int -> Int -> (Int, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,)) [Int]
xs
              ([Maybe Int] -> [(Int, Int)]) -> IO [Maybe Int] -> IO [(Int, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> IO (Maybe Int)) -> [Int] -> IO [Maybe Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int -> Int -> IO (Maybe Int)
runner (Int -> Int -> IO (Maybe Int)) -> Int -> Int -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Int
timeout Int
best_t) [Int]
xs
          Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> (Int, Int)
bestPair ([(Int, Int)] -> (Int, Int)) -> [(Int, Int)] -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Int, Int)
best (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
: [(Int, Int)]
candidates

--- CLI

tune :: AutotuneOptions -> FilePath -> IO Path
tune :: AutotuneOptions -> String -> IO [(String, Int)]
tune AutotuneOptions
opts String
prog = do
  FutharkExe
futhark <- (String -> FutharkExe) -> IO String -> IO FutharkExe
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> FutharkExe
FutharkExe (IO String -> IO FutharkExe) -> IO String -> IO FutharkExe
forall a b. (a -> b) -> a -> b
$ IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getExecutablePath String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO String) -> Maybe String -> IO String
forall a b. (a -> b) -> a -> b
$ AutotuneOptions -> Maybe String
optFuthark AutotuneOptions
opts

  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Compiling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prog String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."
  [(String, RunDataset, Text)]
datasets <- AutotuneOptions
-> FutharkExe -> String -> IO [(String, RunDataset, Text)]
prepare AutotuneOptions
opts FutharkExe
futhark String
prog

  ThresholdForest
forest <- String -> IO ThresholdForest
thresholdForest String
prog
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AutotuneOptions -> Int
optVerbose AutotuneOptions
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (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
"Threshold forest:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [Tree String] -> String
drawForest ([Tree String] -> String) -> [Tree String] -> String
forall a b. (a -> b) -> a -> b
$ (Tree (String, Bool) -> Tree String)
-> ThresholdForest -> [Tree String]
forall a b. (a -> b) -> [a] -> [b]
map (((String, Bool) -> String) -> Tree (String, Bool) -> Tree String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, Bool) -> String
forall a. Show a => a -> String
show) ThresholdForest
forest

  ([(String, Int)]
 -> (String, [(String, Int)]) -> IO [(String, Int)])
-> [(String, Int)]
-> [(String, [(String, Int)])]
-> IO [(String, Int)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (AutotuneOptions
-> [(String, RunDataset, Text)]
-> [(String, Int)]
-> (String, [(String, Int)])
-> IO [(String, Int)]
tuneThreshold AutotuneOptions
opts [(String, RunDataset, Text)]
datasets) [] ([(String, [(String, Int)])] -> IO [(String, Int)])
-> [(String, [(String, Int)])] -> IO [(String, Int)]
forall a b. (a -> b) -> a -> b
$ ThresholdForest -> [(String, [(String, Int)])]
tuningPaths ThresholdForest
forest

runAutotuner :: AutotuneOptions -> FilePath -> IO ()
runAutotuner :: AutotuneOptions -> String -> IO ()
runAutotuner AutotuneOptions
opts String
prog = do
  [(String, Int)]
best <- AutotuneOptions -> String -> IO [(String, Int)]
tune AutotuneOptions
opts String
prog

  let tuning :: String
tuning = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ do
        (String
s, Int
n) <- ((String, Int) -> String) -> [(String, Int)] -> [(String, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (String, Int) -> String
forall a b. (a, b) -> a
fst [(String, Int)]
best
        String -> [String]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n

  case AutotuneOptions -> Maybe String
optTuning AutotuneOptions
opts of
    Maybe String
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just String
suffix -> do
      String -> String -> IO ()
writeFile (String
prog String -> String -> String
<.> String
suffix) String
tuning
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Wrote " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prog String -> String -> String
<.> String
suffix

  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Result of autotuning:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tuning

commandLineOptions :: [FunOptDescr AutotuneOptions]
commandLineOptions :: [FunOptDescr AutotuneOptions]
commandLineOptions =
  [ String
-> [String]
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> FunOptDescr AutotuneOptions
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"r"
      [String
"runs"]
      ( (String -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
n ->
              case ReadS Int
forall a. Read a => ReadS a
reads String
n of
                [(Int
n', String
"")] | Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 ->
                  (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. b -> Either a b
Right ((AutotuneOptions -> AutotuneOptions)
 -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. (a -> b) -> a -> b
$ \AutotuneOptions
config ->
                    AutotuneOptions
config
                      { optRuns :: Int
optRuns = Int
n'
                      }
                [(Int, String)]
_ ->
                  IO () -> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. a -> Either a b
Left (IO () -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> IO () -> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a non-negative integer."
          )
          String
"RUNS"
      )
      String
"Run each test case this many times.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> FunOptDescr AutotuneOptions
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"backend"]
      ( (String -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          (\String
backend -> (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. b -> Either a b
Right ((AutotuneOptions -> AutotuneOptions)
 -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. (a -> b) -> a -> b
$ \AutotuneOptions
config -> AutotuneOptions
config {optBackend :: String
optBackend = String
backend})
          String
"BACKEND"
      )
      String
"The compiler used (defaults to 'opencl').",
    String
-> [String]
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> FunOptDescr AutotuneOptions
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"futhark"]
      ( (String -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          (\String
prog -> (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. b -> Either a b
Right ((AutotuneOptions -> AutotuneOptions)
 -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. (a -> b) -> a -> b
$ \AutotuneOptions
config -> AutotuneOptions
config {optFuthark :: Maybe String
optFuthark = String -> Maybe String
forall a. a -> Maybe a
Just String
prog})
          String
"PROGRAM"
      )
      String
"The binary used for operations (defaults to 'futhark').",
    String
-> [String]
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> FunOptDescr AutotuneOptions
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"pass-option"]
      ( (String -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
opt ->
              (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. b -> Either a b
Right ((AutotuneOptions -> AutotuneOptions)
 -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. (a -> b) -> a -> b
$ \AutotuneOptions
config ->
                AutotuneOptions
config {optExtraOptions :: [String]
optExtraOptions = String
opt String -> [String] -> [String]
forall a. a -> [a] -> [a]
: AutotuneOptions -> [String]
optExtraOptions AutotuneOptions
config}
          )
          String
"OPT"
      )
      String
"Pass this option to programs being run.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> FunOptDescr AutotuneOptions
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"tuning"]
      ( (String -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          (\String
s -> (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. b -> Either a b
Right ((AutotuneOptions -> AutotuneOptions)
 -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. (a -> b) -> a -> b
$ \AutotuneOptions
config -> AutotuneOptions
config {optTuning :: Maybe String
optTuning = String -> Maybe String
forall a. a -> Maybe a
Just String
s})
          String
"EXTENSION"
      )
      String
"Write tuning files with this extension (default: .tuning).",
    String
-> [String]
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> FunOptDescr AutotuneOptions
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      []
      [String
"timeout"]
      ( (String -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
forall a. (String -> a) -> String -> ArgDescr a
ReqArg
          ( \String
n ->
              case ReadS Int
forall a. Read a => ReadS a
reads String
n of
                [(Int
n', String
"")] ->
                  (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. b -> Either a b
Right ((AutotuneOptions -> AutotuneOptions)
 -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. (a -> b) -> a -> b
$ \AutotuneOptions
config -> AutotuneOptions
config {optTimeout :: Int
optTimeout = Int
n'}
                [(Int, String)]
_ ->
                  IO () -> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. a -> Either a b
Left (IO () -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> IO () -> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a non-negative integer."
          )
          String
"SECONDS"
      )
      String
"Initial tuning timeout for each dataset. Later tuning runs are based off of the runtime of the first run.",
    String
-> [String]
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> String
-> FunOptDescr AutotuneOptions
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option
      String
"v"
      [String
"verbose"]
      (Either (IO ()) (AutotuneOptions -> AutotuneOptions)
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
forall a. a -> ArgDescr a
NoArg (Either (IO ()) (AutotuneOptions -> AutotuneOptions)
 -> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions)))
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
-> ArgDescr (Either (IO ()) (AutotuneOptions -> AutotuneOptions))
forall a b. (a -> b) -> a -> b
$ (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. b -> Either a b
Right ((AutotuneOptions -> AutotuneOptions)
 -> Either (IO ()) (AutotuneOptions -> AutotuneOptions))
-> (AutotuneOptions -> AutotuneOptions)
-> Either (IO ()) (AutotuneOptions -> AutotuneOptions)
forall a b. (a -> b) -> a -> b
$ \AutotuneOptions
config -> AutotuneOptions
config {optVerbose :: Int
optVerbose = AutotuneOptions -> Int
optVerbose AutotuneOptions
config Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1})
      String
"Enable logging.  Pass multiple times for more."
  ]

-- | Run @futhark autotune@
main :: String -> [String] -> IO ()
main :: String -> [String] -> IO ()
main = AutotuneOptions
-> [FunOptDescr AutotuneOptions]
-> String
-> ([String] -> AutotuneOptions -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions
  AutotuneOptions
initialAutotuneOptions
  [FunOptDescr AutotuneOptions]
commandLineOptions
  String
"options... program"
  (([String] -> AutotuneOptions -> Maybe (IO ()))
 -> String -> [String] -> IO ())
-> ([String] -> AutotuneOptions -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[String]
progs AutotuneOptions
config ->
    case [String]
progs of
      [String
prog] -> IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ AutotuneOptions -> String -> IO ()
runAutotuner AutotuneOptions
config String
prog
      [String]
_ -> Maybe (IO ())
forall a. Maybe a
Nothing