module Futhark.CLI.Profile (main) where

import Control.Exception (catch)
import Data.ByteString.Lazy.Char8 qualified as BS
import Data.Map qualified as M
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Futhark.Bench
import Futhark.Util (showText)
import Futhark.Util.Options
import System.Directory (createDirectoryIfMissing, removePathForcibly)
import System.FilePath
import System.IO
import Text.Printf

commonPrefix :: (Eq e) => [e] -> [e] -> [e]
commonPrefix :: forall e. Eq e => [e] -> [e] -> [e]
commonPrefix [e]
_ [] = []
commonPrefix [] [e]
_ = []
commonPrefix (e
x : [e]
xs) (e
y : [e]
ys)
  | e
x e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
y = e
x e -> [e] -> [e]
forall a. a -> [a] -> [a]
: [e] -> [e] -> [e]
forall e. Eq e => [e] -> [e] -> [e]
commonPrefix [e]
xs [e]
ys
  | Bool
otherwise = []

longestCommonPrefix :: [FilePath] -> FilePath
longestCommonPrefix :: [String] -> String
longestCommonPrefix [] = String
""
longestCommonPrefix (String
x : [String]
xs) = (String -> String -> String) -> String -> [String] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> String -> String
forall e. Eq e => [e] -> [e] -> [e]
commonPrefix String
x [String]
xs

memoryReport :: M.Map T.Text Integer -> T.Text
memoryReport :: Map Text Integer -> Text
memoryReport = [Text] -> Text
T.unlines ([Text] -> Text)
-> (Map Text Integer -> [Text]) -> Map Text Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"Peak memory usage in bytes" :) ([Text] -> [Text])
-> (Map Text Integer -> [Text]) -> Map Text Integer -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Integer) -> Text) -> [(Text, Integer)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Integer) -> Text
forall {a}. Show a => (Text, a) -> Text
f ([(Text, Integer)] -> [Text])
-> (Map Text Integer -> [(Text, Integer)])
-> Map Text Integer
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Integer -> [(Text, Integer)]
forall k a. Map k a -> [(k, a)]
M.toList
  where
    f :: (Text, a) -> Text
f (Text
space, a
bytes) = Text
space Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showText a
bytes

padRight :: Int -> T.Text -> T.Text
padRight :: Int -> Text -> Text
padRight Int
k Text
s = Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
s) Text
" "

padLeft :: Int -> T.Text -> T.Text
padLeft :: Int -> Text -> Text
padLeft Int
k Text
s = Int -> Text -> Text
T.replicate (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
s) Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s

tabulateEvents :: [ProfilingEvent] -> T.Text
tabulateEvents :: [ProfilingEvent] -> Text
tabulateEvents = [(Text, (Integer, Double))] -> Text
forall {a}.
(Fractional a, PrintfArg a) =>
[(Text, (Integer, a))] -> Text
mkRows ([(Text, (Integer, Double))] -> Text)
-> ([ProfilingEvent] -> [(Text, (Integer, Double))])
-> [ProfilingEvent]
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (Integer, Double) -> [(Text, (Integer, Double))]
forall k a. Map k a -> [(k, a)]
M.toList (Map Text (Integer, Double) -> [(Text, (Integer, Double))])
-> ([ProfilingEvent] -> Map Text (Integer, Double))
-> [ProfilingEvent]
-> [(Text, (Integer, Double))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Integer, Double) -> (Integer, Double) -> (Integer, Double))
-> [(Text, (Integer, Double))] -> Map Text (Integer, Double)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith (Integer, Double) -> (Integer, Double) -> (Integer, Double)
forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b) -> (a, b)
comb ([(Text, (Integer, Double))] -> Map Text (Integer, Double))
-> ([ProfilingEvent] -> [(Text, (Integer, Double))])
-> [ProfilingEvent]
-> Map Text (Integer, Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProfilingEvent -> (Text, (Integer, Double)))
-> [ProfilingEvent] -> [(Text, (Integer, Double))]
forall a b. (a -> b) -> [a] -> [b]
map ProfilingEvent -> (Text, (Integer, Double))
forall {a}. Num a => ProfilingEvent -> (Text, (a, Double))
pair
  where
    pair :: ProfilingEvent -> (Text, (a, Double))
pair (ProfilingEvent Text
name Double
dur Text
_) = (Text
name, (a
1, Double
dur))
    comb :: (a, b) -> (a, b) -> (a, b)
comb (a
xn, b
xdur) (a
yn, b
ydur) = (a
xn a -> a -> a
forall a. Num a => a -> a -> a
+ a
yn, b
xdur b -> b -> b
forall a. Num a => a -> a -> a
+ b
ydur)
    numpad :: Int
numpad = Int
15
    mkRows :: [(Text, (Integer, a))] -> Text
mkRows [(Text, (Integer, a))]
rows =
      let longest :: Int
longest = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
numpad ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((Text, (Integer, a)) -> Int) -> [(Text, (Integer, a))] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Int
T.length (Text -> Int)
-> ((Text, (Integer, a)) -> Text) -> (Text, (Integer, a)) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, (Integer, a)) -> Text
forall a b. (a, b) -> a
fst) [(Text, (Integer, a))]
rows
          header :: Text
header = Int -> Text
headerRow Int
longest
          splitter :: Text
splitter = (Char -> Char) -> Text -> Text
T.map (Char -> Char -> Char
forall a b. a -> b -> a
const Char
'-') Text
header
          bottom :: Text
bottom =
            [Text] -> Text
T.unwords
              [ Integer -> Text
forall a. Show a => a -> Text
showText ([Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Text, (Integer, a)) -> Integer)
-> [(Text, (Integer, a))] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map ((Integer, a) -> Integer
forall a b. (a, b) -> a
fst ((Integer, a) -> Integer)
-> ((Text, (Integer, a)) -> (Integer, a))
-> (Text, (Integer, a))
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, (Integer, a)) -> (Integer, a)
forall a b. (a, b) -> b
snd) [(Text, (Integer, a))]
rows)),
                Text
"events with a total runtime of ",
                String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> a -> String
forall r. PrintfType r => String -> r
printf String
"%.2fμs" (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ ((Text, (Integer, a)) -> a) -> [(Text, (Integer, a))] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((Integer, a) -> a
forall a b. (a, b) -> b
snd ((Integer, a) -> a)
-> ((Text, (Integer, a)) -> (Integer, a))
-> (Text, (Integer, a))
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, (Integer, a)) -> (Integer, a)
forall a b. (a, b) -> b
snd) [(Text, (Integer, a))]
rows
              ]
       in [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
            Text
header
              Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
splitter
              Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Text, (Integer, a)) -> Text) -> [(Text, (Integer, a))] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> (Text, (Integer, a)) -> Text
forall {a}.
(PrintfArg a, Fractional a) =>
Int -> (Text, (Integer, a)) -> Text
mkRow Int
longest) [(Text, (Integer, a))]
rows
                [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
splitter, Text
bottom]
    headerRow :: Int -> Text
headerRow Int
longest =
      [Text] -> Text
T.unwords
        [ Int -> Text -> Text
padLeft Int
longest Text
"Cost centre",
          Int -> Text -> Text
padLeft Int
numpad Text
"count",
          Int -> Text -> Text
padLeft Int
numpad Text
"total",
          Int -> Text -> Text
padLeft Int
numpad Text
"mean"
        ]
    mkRow :: Int -> (Text, (Integer, a)) -> Text
mkRow Int
longest (Text
name, (Integer
n, a
dur)) =
      [Text] -> Text
T.unwords
        [ Int -> Text -> Text
padRight Int
longest Text
name,
          Int -> Text -> Text
padLeft Int
numpad (Integer -> Text
forall a. Show a => a -> Text
showText Integer
n),
          Int -> Text -> Text
padLeft Int
numpad (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> a -> String
forall r. PrintfType r => String -> r
printf String
"%.2fμs" a
dur,
          Int -> Text -> Text
padLeft Int
numpad (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> a -> String
forall r. PrintfType r => String -> r
printf String
"%.2fμs" (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ a
dur a -> a -> a
forall a. Fractional a => a -> a -> a
/ Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
n
        ]

analyseProfileReport :: FilePath -> [BenchResult] -> IO ()
analyseProfileReport :: String -> [BenchResult] -> IO ()
analyseProfileReport String
json_path [BenchResult]
bench_results = do
  let top_dir :: String
top_dir = String -> String
takeFileName String
json_path String -> String -> String
-<.> String
"prof"
  Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Writing results to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
top_dir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
  Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Stripping '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' from program paths."
  String -> IO ()
removePathForcibly String
top_dir
  (BenchResult -> IO ()) -> [BenchResult] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> BenchResult -> IO ()
onBenchResult String
top_dir) [BenchResult]
bench_results
  where
    prefix :: String
prefix = [String] -> String
longestCommonPrefix ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (BenchResult -> String) -> [BenchResult] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map BenchResult -> String
benchResultProg [BenchResult]
bench_results

    -- Eliminate characters that are filesystem-meaningful.
    escape :: Char -> Char
escape Char
'/' = Char
'_'
    escape Char
c = Char
c

    problem :: Text -> Text -> Text -> IO ()
problem Text
prog_name Text
name Text
what =
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
prog_name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" dataset " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what

    onBenchResult :: String -> BenchResult -> IO ()
onBenchResult String
top_dir (BenchResult String
prog_path [DataResult]
data_results) = do
      let (String
prog_path', String
entry) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
prog_path
          prog_name :: String
prog_name = Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix) String
prog_path'
          prog_dir :: String
prog_dir = String
top_dir String -> String -> String
</> String -> String
dropExtension String
prog_name String -> String -> String
</> Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
entry
      Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
prog_dir
      (DataResult -> IO ()) -> [DataResult] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Text -> DataResult -> IO ()
onDataResult String
prog_dir (String -> Text
T.pack String
prog_name)) [DataResult]
data_results

    onDataResult :: String -> Text -> DataResult -> IO ()
onDataResult String
_ Text
prog_name (DataResult Text
name (Left Text
_)) =
      Text -> Text -> Text -> IO ()
problem Text
prog_name Text
name Text
"execution failed"
    onDataResult String
prog_dir Text
prog_name (DataResult Text
name (Right Result
res)) = do
      let name' :: String
name' = String
prog_dir String -> String -> String
</> Text -> String
T.unpack ((Char -> Char) -> Text -> Text
T.map Char -> Char
escape Text
name)
      case Result -> Maybe Text
stdErr Result
res of
        Maybe Text
Nothing -> Text -> Text -> Text -> IO ()
problem Text
prog_name Text
name Text
"no log recorded"
        Just Text
text -> String -> Text -> IO ()
T.writeFile (String
name' String -> String -> String
<.> String
".log") Text
text
      case Result -> Maybe ProfilingReport
report Result
res of
        Maybe ProfilingReport
Nothing -> Text -> Text -> Text -> IO ()
problem Text
prog_name Text
name Text
"no profiling information"
        Just ProfilingReport
r ->
          String -> Text -> IO ()
T.writeFile (String
name' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".summary") (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
            Map Text Integer -> Text
memoryReport (ProfilingReport -> Map Text Integer
profilingMemory ProfilingReport
r)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [ProfilingEvent] -> Text
tabulateEvents (ProfilingReport -> [ProfilingEvent]
profilingEvents ProfilingReport
r)

readFileSafely :: FilePath -> IO (Either String BS.ByteString)
readFileSafely :: String -> IO (Either String ByteString)
readFileSafely String
filepath =
  (ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> IO ByteString -> IO (Either String ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
filepath) IO (Either String ByteString)
-> (IOError -> IO (Either String ByteString))
-> IO (Either String ByteString)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO (Either String ByteString)
forall {f :: * -> *} {b}.
Applicative f =>
IOError -> f (Either String b)
couldNotRead
  where
    couldNotRead :: IOError -> f (Either String b)
couldNotRead IOError
e = Either String b -> f (Either String b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String b -> f (Either String b))
-> Either String b -> f (Either String b)
forall a b. (a -> b) -> a -> b
$ String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ IOError -> String
forall a. Show a => a -> String
show (IOError
e :: IOError)

decodeFileBenchResults ::
  FilePath ->
  IO (Either String [BenchResult])
decodeFileBenchResults :: String -> IO (Either String [BenchResult])
decodeFileBenchResults String
path = do
  Either String ByteString
file <- String -> IO (Either String ByteString)
readFileSafely String
path
  Either String [BenchResult] -> IO (Either String [BenchResult])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String [BenchResult] -> IO (Either String [BenchResult]))
-> Either String [BenchResult] -> IO (Either String [BenchResult])
forall a b. (a -> b) -> a -> b
$ Either String ByteString
file Either String ByteString
-> (ByteString -> Either String [BenchResult])
-> Either String [BenchResult]
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Either String [BenchResult]
decodeBenchResults

-- | Run @futhark profile@.
main :: String -> [String] -> IO ()
main :: String -> [String] -> IO ()
main = ()
-> [FunOptDescr ()]
-> String
-> ([String] -> () -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions () [] String
"<file>" [String] -> () -> Maybe (IO ())
f
  where
    f :: [String] -> () -> Maybe (IO ())
f [String
json_path] () = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ do
      Either String [BenchResult]
res_either <- String -> IO (Either String [BenchResult])
decodeFileBenchResults String
json_path

      case Either String [BenchResult]
res_either of
        Left String
a -> Handle -> String -> IO ()
hPutStrLn Handle
stderr String
a
        Right [BenchResult]
a -> String -> [BenchResult] -> IO ()
analyseProfileReport String
json_path [BenchResult]
a
    f [String]
_ ()
_ = Maybe (IO ())
forall a. Maybe a
Nothing