summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore1
-rw-r--r--Main.hs111
-rw-r--r--Parse.hs131
-rw-r--r--Prof.hs28
-rw-r--r--ghc-prof-reader.cabal21
5 files changed, 292 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..c33954f
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+dist-newstyle/
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..a6b45e8
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE PatternSynonyms #-}
+module Main where
+
+import Prelude hiding (splitAt)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Short as BSS
+import qualified Data.Sequence as Seq
+import Data.Sequence (Seq, (<|), pattern (:<|))
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import System.Environment
+import System.Exit
+
+import Brick
+import Brick.Widgets.List
+import Graphics.Vty.Attributes
+import Graphics.Vty.Input.Events (Event(..), Key(..))
+
+import Parse
+import Prof
+
+
+data Name = NList
+ deriving (Show, Eq, Ord)
+
+-- Row indent subtree
+data Row = Row Int (ProfTree Bool)
+
+data AppState
+ = AppState { aList :: GenericList Name Seq Row }
+
+initAppState :: Prof () -> AppState
+initAppState doc =
+ let Prof tree = fmap (const False) doc
+ in AppState (list NList (Seq.singleton (Row 0 tree)) 1)
+
+rowEntry :: Row -> Entry
+rowEntry (Row _ (Node e _ _)) = e
+rowEntry (Row _ (Leaf e)) = e
+
+buildSubtree :: Int -> ProfTree Bool -> [Row]
+buildSubtree indent tree@(Leaf _) = [Row indent tree]
+buildSubtree indent tree@(Node _ False _) = [Row indent tree]
+buildSubtree indent tree@(Node _ True ch) =
+ Row indent tree : concatMap (buildSubtree (indent + 1)) ch
+
+draw :: AppState -> [Widget Name]
+draw app = [renderList func True (aList app)]
+ where func selected row@(Row indent _) =
+ let selfunc1 = if selected then withAttr (attrName "selectedRow") else id
+ selfunc2 = if selected then withAttr (attrName "selected") else id
+ entry = rowEntry row
+ TimeShare inhTime inhAlloc = eInherited entry
+ in selfunc1 $
+ hBox [txt (T.replicate indent (T.singleton ' '))
+ ,selfunc2 (txt (mconcat
+ [T.decodeUtf8 (BSS.fromShort (eCS entry))
+ ,T.pack " "
+ ,T.decodeUtf8 (BSS.fromShort (eModule entry))]))
+ ,vLimit 1 (fill ' ')
+ ,txt (T.pack (show inhTime ++ " " ++ show inhAlloc))]
+
+handleEvent :: AppState -> BrickEvent Name e -> EventM Name (Next AppState)
+handleEvent app (VtyEvent (EvKey (KChar 'q') _)) = halt app
+handleEvent app (VtyEvent event) = do
+ list' <- handleListEventVi fallback event (aList app)
+ continue (app { aList = list' })
+ where
+ fallback (EvKey (KChar ' ') []) l =
+ case listSelectedElement l of
+ Just (_, Row _ (Leaf _)) -> return l
+ Just (index, Row indent (Node entry False ch)) ->
+ let (preelts, _ :<| postelts) = splitAt index (listElements l)
+ mid = Seq.fromList (buildSubtree indent (Node entry True ch))
+ in return (listReplace (preelts <> mid <> postelts) (Just index) l)
+ Just (index, Row indent (Node entry True ch)) ->
+ let (preelts, elts) = splitAt index (listElements l)
+ sublen = length (buildSubtree indent (Node entry True ch))
+ postelts = Seq.drop sublen elts
+ in return (listReplace (preelts <> (Row indent (Node entry False ch) <| postelts)) (Just index) l)
+ Nothing -> return l
+ fallback e l = handleListEvent e l
+handleEvent app _ = continue app
+
+main :: IO ()
+main = do
+ args <- getArgs
+ inputFile <- case args of
+ ["-v"] -> do
+ putStrLn "ghc-prof-reader by Tom Smeding"
+ putStrLn "Usage: ghc-prof-reader <file.prof>"
+ exitSuccess
+ [fname] -> BS.readFile fname
+ _ -> die "Usage: ghc-prof-reader <file.prof>"
+
+ putStrLn "Reading..."
+ doc <- case parseProf inputFile of
+ Right doc -> return doc
+ Left err -> die err
+ doc `seq` putStrLn "Imported"
+
+ _ <- defaultMain
+ (App { appDraw = draw
+ , appChooseCursor = \_ l -> if null l then Nothing else Just (head l)
+ , appHandleEvent = handleEvent
+ , appStartEvent = return
+ , appAttrMap = \_ -> attrMap defAttr
+ [(attrName "selected", withStyle defAttr standout)
+ ,(attrName "selectedRow", withStyle defAttr underline)] })
+ (initAppState doc)
+ return ()
diff --git a/Parse.hs b/Parse.hs
new file mode 100644
index 0000000..0ee5004
--- /dev/null
+++ b/Parse.hs
@@ -0,0 +1,131 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
+module Parse (parseProf) where
+
+import Control.Applicative ((<|>))
+import Control.Monad (guard)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Short as BSS
+import Data.ByteString (ByteString)
+import Data.Char
+import Data.List (unfoldr)
+
+import Prof
+
+
+data Columns
+ = Columns { cMod :: Int
+ , cSrc :: Int
+ , cNo :: Int
+ , cCnt :: Int
+ , cIvT :: Int -- individual time/alloc
+ , cIvA :: Int
+ , cIhT :: Int -- inherited time/alloc
+ , cIhA :: Int }
+ deriving (Show)
+
+parseProf :: ByteString -> Either String (Prof ())
+parseProf input = do
+ (cols, lns) <- maybe (Left "Did not find tree header") Right (findTree (BS.split 10 input))
+ lns' <- concat <$> mapM (parseLine cols) lns
+ case buildTree lns' of
+ Just (tree, []) -> return (Prof tree)
+ Just (_, l) -> Left ("Found " ++ show (length l) ++ " unexpected lines after tree")
+ Nothing -> Left "Empty tree found"
+
+parseLine :: Columns -> ByteString -> Either String [(Int, Entry)]
+parseLine _ line | BS.null line = Right []
+parseLine cols line = either (\err -> Left (err ++ ": <" ++ BS8.unpack line ++ ">")) Right $ do
+ let indent = BS.length (BS.takeWhile (== 32) line)
+ scs = getCol 0 (cMod cols)
+ smod = getCol (cMod cols) (cSrc cols)
+ ssrc = getCol (cSrc cols) (cNo cols)
+ scnt = getCol (cCnt cols) (cIvT cols)
+ sivt = getCol (cIvT cols) (cIvA cols)
+ siva = getCol (cIvA cols) (cIhT cols)
+ siht = getCol (cIhT cols) (cIhA cols)
+ siha = getCol (cIhA cols) (BS.length line)
+ smod' <- nonEmpty smod "module"
+ ssrc' <- nonEmpty ssrc "src"
+ ncnt <- parseInt scnt "entries"
+ fivt <- parseFloat sivt "individual %time"
+ fiva <- parseFloat siva "individual %alloc"
+ fiht <- parseFloat siht "inherited %time"
+ fiha <- parseFloat siha "inherited %alloc"
+ return [(indent, Entry { eCS = BSS.toShort scs
+ , eModule = BSS.toShort smod'
+ , eSrc = BSS.toShort ssrc'
+ , eCount = ncnt
+ , eIndividual = TimeShare fivt fiva
+ , eInherited = TimeShare fiht fiha })]
+ where
+ getCol :: Int -> Int -> ByteString
+ getCol from to =
+ let part = BS.drop from (BS.take to line)
+ in BS.dropWhile (== 32) (BS.dropWhileEnd (== 32) part)
+
+ nonEmpty bs descr = if BS.null bs then Left ("Unexpected empty " ++ descr ++ " field") else Right bs
+
+ parseInt bs descr = case BS8.readInt bs of
+ Just (n, rest) | BS.null rest -> Right n
+ _ -> Left ("Cannot parse integer from '" ++ BS8.unpack bs ++ "' in " ++ descr ++ " field: <" ++ BS8.unpack bs ++ ">")
+
+ parseFloat bs descr =
+ let mres = do
+ (whole, bs1) <- BS8.readInt bs
+ guard (not (BS.null bs1) && BS.head bs1 == fromIntegral (ord '.'))
+ let sfract = BS.tail bs1
+ (fract, bs2) <- BS8.readInt sfract
+ guard (BS.null bs2)
+ return (fromIntegral whole + fromIntegral fract / 10 ^ BS.length sfract)
+ in case mres of
+ Just f -> Right f
+ Nothing -> Left ("Cannot parse float from '" ++ BS8.unpack bs ++ "' in " ++ descr ++ " field: <" ++ BS8.unpack bs ++ ">")
+
+findTree :: [ByteString] -> Maybe (Columns, [ByteString])
+findTree [] = Nothing
+findTree (ln:lns) = fmap (,lns) (parseLeadingTreeLine ln) <|> findTree lns
+
+parseLeadingTreeLine :: ByteString -> Maybe Columns
+parseLeadingTreeLine bs = do
+ (0, bs1) <- findCol "COST CENTRE" 0 bs
+ (cmod, bs2) <- findCol "MODULE" 11 bs1
+ (csrc, bs3) <- findCol "SRC" (cmod+6) bs2
+ (cno, bs4) <- findCol "no." (csrc+3) bs3
+ (centr, bs5) <- findCol "entries" (cno+3) bs4
+ (civt, bs6) <- findCol "%time" (centr+7) bs5
+ (civa, bs7) <- findCol "%alloc" (civt+5) bs6
+ (ciht, bs8) <- findCol "%time" (civa+6) bs7
+ (_ciha, _bs9) <- findCol "%alloc" (ciht+5) bs8
+ return $ Columns { cMod = cmod
+ , cSrc = csrc
+ , cNo = cno
+ , cCnt = cno + 5
+ , cIvT = centr + 6
+ , cIvA = civt + 4
+ , cIhT = civa + 5
+ , cIhA = ciht + 4 }
+ where
+ findCol :: String -> Int -> ByteString -> Maybe (Int, ByteString)
+ findCol stag from = \line ->
+ case go 0 line of
+ Nothing -> Nothing
+ Just (col, rest) -> Just (from + col, rest)
+ where
+ tag :: ByteString
+ tag = BS.pack (map (fromIntegral . ord) stag)
+
+ go :: Int -> ByteString -> Maybe (Int, ByteString)
+ go !idx line
+ | BS.length line < BS.length tag = Nothing
+ | BS.take (BS.length tag) line == tag = Just (idx, BS.drop (BS.length tag) line)
+ | otherwise = go (idx + 1) (BS.tail line)
+
+buildTree :: [(Int, Entry)] -> Maybe (ProfTree (), [(Int, Entry)])
+buildTree [] = Nothing
+buildTree ((depth, entry) : items) =
+ let (below, after) = span ((> depth) . fst) items
+ subs = unfoldr buildTree below
+ in Just (Node entry () subs, after)
diff --git a/Prof.hs b/Prof.hs
new file mode 100644
index 0000000..28bfaca
--- /dev/null
+++ b/Prof.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE DeriveFunctor #-}
+module Prof where
+
+import Data.ByteString.Short (ShortByteString)
+
+
+data Prof a
+ = Prof { pTree :: ProfTree a }
+ deriving (Show, Functor)
+
+data ProfTree a
+ = Leaf Entry
+ | Node Entry a [ProfTree a]
+ deriving (Show, Functor)
+
+data Entry
+ = Entry { eCS :: ShortByteString
+ , eModule :: ShortByteString
+ , eSrc :: ShortByteString
+ , eCount :: Int
+ , eIndividual :: TimeShare
+ , eInherited :: TimeShare }
+ deriving (Show)
+
+data TimeShare
+ = TimeShare { tsTime :: Double
+ , tsAlloc :: Double }
+ deriving (Show)
diff --git a/ghc-prof-reader.cabal b/ghc-prof-reader.cabal
new file mode 100644
index 0000000..ee2bae2
--- /dev/null
+++ b/ghc-prof-reader.cabal
@@ -0,0 +1,21 @@
+cabal-version: >=1.10
+name: ghc-prof-reader
+synopsis: Tree traversal app for GHC profiling output
+version: 0.0.1.0
+license: MIT
+author: Tom Smeding
+maintainer: tom.smeding@gmail.com
+build-type: Simple
+
+executable ghc-prof-reader
+ main-is: Main.hs
+ other-modules: Parse, Prof
+ build-depends: base >= 4.13 && < 4.15,
+ containers >= 0.6.4 && < 0.7,
+ bytestring >= 0.10.12 && < 0.11,
+ brick >= 0.57 && < 0.58,
+ vty,
+ text >= 1.2.4 && < 1.3
+ hs-source-dirs: .
+ default-language: Haskell2010
+ ghc-options: -Wall -O2 -threaded