diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for viewprof + +## 0.0.0 (2017-01-20) + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Mitsutoshi Aoe + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Mitsutoshi Aoe nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bin/viewprof.hs b/bin/viewprof.hs new file mode 100644 --- /dev/null +++ b/bin/viewprof.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where +import Control.Arrow ((&&&)) +import Control.Monad +import Data.Foldable +import Data.Function (on) +import Data.List.NonEmpty +import Data.Maybe +import System.Environment +import Text.Printf +import qualified Data.List.NonEmpty as NE + +import Brick hiding (on) +import Control.Lens hiding (views) +import Data.Set (Set) +import Graphics.Vty +import qualified Brick +import qualified Brick.Widgets.Border as Brick +import qualified Brick.Widgets.Center as Brick +import qualified Data.Scientific as Sci +import qualified Data.Set as Set +import qualified Data.Text.Lazy.IO as TL +import qualified Data.Vector as V +import qualified Data.Vector.Algorithms.Merge as Merge +import qualified GHC.Prof as Prof + +data Profile = Profile + { _report :: Prof.Profile + , _views :: NonEmpty View + , _modalView :: Maybe ModalView + , _lastKeyEvent :: !(Maybe (Key, [Modifier])) + } + +data View + = AggregatesView + { _costCentres :: !(V.Vector Prof.AggregateCostCentre) + , _focus :: !Int + } + | CallSitesView + { _callee :: !Prof.AggregateCostCentre + , _callSites :: !(V.Vector (Prof.CallSite Prof.AggregateCostCentre)) + , _focus :: !Int + , _expanded :: !(Set Int) + } + | ModulesView + { _modules :: !(V.Vector Prof.AggregateModule) + , _focus :: !Int + } + +data ModalView + = InfoView + | HelpView + +makeLenses ''Profile +makeLenses ''View + +data Name + = AggregatesViewport + | CallSitesViewport + | ModulesViewport + | AggregatesCache !Int + | CallSitesCache !Int + | ModulesCache !Int + deriving (Eq, Ord, Show) + +main :: IO () +main = do + path:_ <- getArgs + profile <- parseProfile path + void $ defaultMain app profile + +parseProfile :: FilePath -> IO Profile +parseProfile path = do + contents <- TL.readFile path + case Prof.decode contents of + Left reason -> fail reason + Right prof -> return Profile + { _report = prof + , _views = AggregatesView + { _costCentres = V.fromList (Prof.aggregateCostCentres prof) + , _focus = 0 + } :| [] + , _modalView = Nothing + , _lastKeyEvent = Nothing + } + +app :: App Profile e Name +app = App + { appDraw = drawProfile + , appChooseCursor = neverShowCursor + , appHandleEvent = handleProfileEvent + , appStartEvent = return + , appAttrMap = const $ attrMap defAttr + [ (selectedAttr, black `Brick.on` white) + ] + } + +handleProfileEvent :: Profile -> BrickEvent Name e -> EventM Name (Next Profile) +handleProfileEvent prof@Profile {..} ev = case ev of + VtyEvent vtyEv -> case vtyEv of + EvResize {} -> do + invalidateCache + continue prof + EvKey key [] + | key `elem` [KEsc, KChar 'q'] -> if + | Just _ <- prof ^. modalView -> do + invalidateCache + continue $! prof & modalView .~ Nothing + | null (NE.tail (prof ^. views)) -> halt prof + | otherwise -> do + invalidateCache + continue $! popView prof + | key `elem` [KUp, KChar 'k'] -> do + let !pos = prof ^. currentFocus + for_ [pos, pos-1] $ invalidateCacheEntry . currentCacheEntry prof + continue $! moveUp prof + | key `elem` [KDown, KChar 'j'] -> do + let !pos = prof ^. currentFocus + for_ [pos, pos+1] $ invalidateCacheEntry . currentCacheEntry prof + continue $! moveDown prof + | key `elem` [KChar 'C'] -> do + invalidateCache + continue $! displayCostCentres prof + | key `elem` [KChar 'M'] -> do + invalidateCache + continue $! displayModules prof + | key `elem` [KChar 'g'] -> + if prof ^. lastKeyEvent == Just (KChar 'g', []) + then do + invalidateCache + continue $! moveToTop $ prof & lastKeyEvent .~ Nothing + else + continue $! prof & lastKeyEvent .~ Just (key, []) + | key `elem` [KChar 'G'] -> do + invalidateCache + continue $! moveToEnd prof + | key `elem` [KChar 'i'] -> + continue $! prof & modalView ?~ InfoView + | key `elem` [KChar 'h', KChar '?'] -> + continue $! prof & modalView ?~ HelpView + _ -> case NE.head _views of + AggregatesView {} -> case vtyEv of + EvKey (KChar 't') [] -> do + invalidateCache + continue $! sortCostCentresBy + (Prof.aggregateCostCentreTime &&& Prof.aggregateCostCentreAlloc) + prof + EvKey (KChar 'a') [] -> do + invalidateCache + continue $! sortCostCentresBy + (Prof.aggregateCostCentreAlloc &&& Prof.aggregateCostCentreTime) + prof + EvKey (KChar 'e') [] -> do + invalidateCache + continue $! sortCostCentresBy + Prof.aggregateCostCentreEntries + prof + EvKey key [] + | key `elem` [KEnter] -> do + invalidateCache + continue $! displayCallers prof + _ -> continue prof + CallSitesView {} -> case vtyEv of + EvKey (KChar 't') [] -> do + invalidateCache + continue $! sortCallSitesBy + (Prof.callSiteContribTime &&& Prof.callSiteContribAlloc) + prof + EvKey (KChar 'a') [] -> do + invalidateCache + continue $! sortCallSitesBy + (Prof.callSiteContribAlloc &&& Prof.callSiteContribTime) + prof + EvKey (KChar 'e') [] -> do + invalidateCache + continue $! sortCallSitesBy + Prof.callSiteContribEntries + prof + _ -> continue prof + ModulesView {} -> continue prof + _ -> continue prof + where + popView p = case NE.nonEmpty (NE.tail _views) of + Nothing -> p + Just xs -> p & views .~ xs + moveUp p = p & currentFocus %~ (\i -> max 0 (i - 1)) + moveDown p = p & currentFocus %~ (\i -> min (focusLen p - 1) (i + 1)) + moveToTop p = p & currentFocus .~ 0 + moveToEnd p = p & currentFocus .~ focusLen p - 1 + focusLen p = case p ^. topView of + AggregatesView {_costCentres} -> V.length _costCentres + CallSitesView {_callSites} -> V.length _callSites + ModulesView {_modules} -> V.length _modules + sortCostCentresBy key p = p & topView . costCentres + %~ V.modify (Merge.sortBy (flip compare `on` key)) + sortCallSitesBy key p = p & topView . callSites + %~ V.modify (Merge.sortBy (flip compare `on` key)) + displayCostCentres p = p & views .~ AggregatesView + { _costCentres = V.fromList $ Prof.aggregateCostCentres $ p ^. report + , _focus = 0 + } NE.:| [] + displayCallers p = fromMaybe p $ do + let !model = p ^. topView . costCentres + !idx = p ^. currentFocus + Prof.AggregateCostCentre {..} <- model V.!? idx + (_callee, callers) <- Prof.aggregateCallSites + aggregateCostCentreName + aggregateCostCentreModule + (p ^. report) + return $! p & views %~ NE.cons CallSitesView + { _callee + , _callSites = V.fromList callers + , _focus = 0 + , _expanded = Set.empty + } + displayModules p = p & views .~ ModulesView + { _modules = V.fromList $ Prof.aggregateModules $ p ^. report + , _focus = 0 + } NE.:| [] + +topView :: Lens' Profile View +topView = views . lens NE.head (\(_ NE.:| xs) x -> x NE.:| xs) +{-# INLINE topView #-} + +currentFocus :: Lens' Profile Int +currentFocus = topView . focus +{-# INLINE currentFocus #-} + +currentViewport :: Profile -> Name +currentViewport p = case p ^. topView of + AggregatesView {} -> AggregatesViewport + CallSitesView {} -> CallSitesViewport + ModulesView {} -> ModulesViewport + +currentCacheEntry :: Profile -> Int -> Name +currentCacheEntry p n = case p ^. topView of + AggregatesView {} -> AggregatesCache n + CallSitesView {} -> CallSitesCache n + ModulesView {} -> ModulesCache n + +profileAttr :: AttrName +profileAttr = "profile" + +selectedAttr :: AttrName +selectedAttr = "selected" + +drawProfile :: Profile -> [Widget Name] +drawProfile prof = + [ maybe emptyWidget (Brick.centerLayer . drawModalView) (prof ^. modalView) + , drawView $ NE.head $ prof ^. views + ] + where + drawModalView = \case + InfoView -> Brick.border $ vBox + [ txt $ prof ^. report . to Prof.profileCommandLine + -- TODO: add more + ] + HelpView -> Brick.borderWithLabel (txt "Help") $ vBox + [ txt "Keyboard shortcuts" + , txt "q quit current view" + , txt "j,down move down" + , txt "k,up move up" + , txt "gg move to the top" + , txt "G move to the bottom" + , txt "C switch to aggregate cost centre view" + , txt "enter switch to call site view" + , txt "M switch to module level breakdown" + , txt "i display profiling info" + , txt "h display help message" + , txt "t sort by time" + , txt "a sort by allocation" + , txt "e sort by number of entries" + ] + drawView = \case + AggregatesView {..} -> viewport AggregatesViewport Vertical $ + vBox $ V.toList $ + flip V.imap _costCentres $ \i row -> cached (AggregatesCache i) $ + let widget = drawAggregateCostCentre row + in if i == _focus + then withAttr selectedAttr (visible widget) + else widget + CallSitesView {..} -> viewport CallSitesViewport Vertical $ + vBox + [ drawAggregateCostCentre _callee + , vBox $ V.toList $ flip V.imap _callSites $ \i row -> + cached (CallSitesCache i) $ + let widget = drawCallSite _callee row + in if i == _focus + then withAttr selectedAttr (visible widget) + else widget + ] + ModulesView {..} -> viewport ModulesViewport Vertical $ + vBox $ V.toList $ + flip V.imap _modules $ \i row -> cached (ModulesCache i) $ + let widget = drawAggregateModule row + in if i == _focus + then withAttr selectedAttr (visible widget) + else widget + +drawAggregateCostCentre :: Prof.AggregateCostCentre -> Widget n +drawAggregateCostCentre Prof.AggregateCostCentre {..} = hBox + [ txt aggregateCostCentreModule + , txt "." + , padRight Max $ txt aggregateCostCentreName + , maybe emptyWidget (padRight (Pad 1) . str . show) aggregateCostCentreEntries + , padRight (Pad 1) $ str (formatPercentage aggregateCostCentreTime) + , str (formatPercentage aggregateCostCentreAlloc) + ] + +drawCallSite + :: Prof.AggregateCostCentre + -> Prof.CallSite Prof.AggregateCostCentre + -> Widget n +drawCallSite Prof.AggregateCostCentre {..} Prof.CallSite {..} = hBox + [ txt $ Prof.aggregateCostCentreModule callSiteCostCentre + , txt "." + , padRight Max $ txt $ Prof.aggregateCostCentreName callSiteCostCentre + , padRight (Pad 1) $ str $ show callSiteContribEntries + , padRight (Pad 1) $ hBox + [ str $ contribution callSiteContribTime aggregateCostCentreTime + , txt " (" + , str $ formatPercentage callSiteContribTime + , txt ")" + ] + , hBox + [ str $ contribution callSiteContribAlloc aggregateCostCentreAlloc + , txt " (" + , str $ formatPercentage callSiteContribAlloc + , txt ")" + ] + ] + where + contribution part whole + | whole == 0 = formatPercentage 0 + | otherwise = formatPercentage $ Sci.fromFloatDigits $ + 100 * (Sci.toRealFloat part / Sci.toRealFloat whole :: Double) + +drawAggregateModule :: Prof.AggregateModule -> Widget n +drawAggregateModule Prof.AggregateModule {..} = hBox + [ txt aggregateModuleName + , padLeft Max $ str (formatPercentage aggregateModuleTime) + , padLeft (Pad 1) $ str (formatPercentage aggregateModuleAlloc) + ] + +formatPercentage :: Sci.Scientific -> String +formatPercentage = printf "%5s%%" . Sci.formatScientific Sci.Fixed (Just 1) diff --git a/viewprof.cabal b/viewprof.cabal new file mode 100644 --- /dev/null +++ b/viewprof.cabal @@ -0,0 +1,32 @@ +name: viewprof +version: 0.0.0 +synopsis: Text-based interactive GHC .prof viewer +-- description: +license: BSD3 +license-file: LICENSE +author: Mitsutoshi Aoe +maintainer: Mitsutoshi Aoe +copyright: Copyright (C) 2016 Mitsutoshi Aoe +category: Development +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >= 1.10 +tested-with: GHC == 8.0.2 + +executable viewprof + main-is: viewprof.hs + -- other-extensions: + build-depends: + base >= 4.9 && < 4.10 + , brick >= 0.16 && < 0.17 + , containers >= 0.5.7 && < 0.6 + , ghc-prof >= 1.3.0 && < 1.4 + , lens >= 4.14 && < 4.16 + , scientific >= 0.3.4.4 && < 0.4 + , text >= 1.2.2.0 && < 1.3 + , vector >= 0.10.12.3 && < 0.13 + , vector-algorithms >= 0.6.0.4 && < 0.8 + , vty >= 5.13 && < 5.15 + hs-source-dirs: bin + default-language: Haskell2010 + ghc-options: -Wall -threaded