diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Main.hs | 111 | ||||
| -rw-r--r-- | Parse.hs | 131 | ||||
| -rw-r--r-- | Prof.hs | 28 | ||||
| -rw-r--r-- | ghc-prof-reader.cabal | 21 |
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/ @@ -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) @@ -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 |