diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,40 @@ -2014-09-23 Will Sewell +0.2.3 - * Version 0.2.2 adds support for GHC 7.10 + * Add new command line options: `--tick-every`, `--bucket-width`, + `--bucket-height`, and `--border-width`. This allows to get both the + behaviour we used in the blogpost and the behaviour that was implemented + by Andrew Farmer in 0.2.1 + (2016-10-03 Edsko de Vries ) + * Fix issue with thread creation before window start + (2015-09-29, Will Sewell ) + * Bump optparse-applicative and lens versions + (2015-01-19, Will Sewell ) -2014-02-12 Edsko de Vries +0.2.2 - * Initial release + * Adds support for GHC 7.10 + (2015-09-23, Will Sewell ) + (2015-05-29, GaneshRapolu ) + +0.2.1 + + * Various new features: slice time more finely, add sorting options for timed + report, more colours, support for ms on the timeline, use alternating + colours for background, support for windowing. + (2014-12-06, Andrew Farmer ) + * Make sure _shutdown is always set, so that event logs from programs + that terminated abnormally can still be visualized + (2014-03-14, Bas van Dijk ) + * Relax bounds + (2014-05-28, Dominic Steinitz ) + (2014-11-05, Alexander Vershilov ) + (2014-11-07, Andrew Farmer ) + * Move to diagrams 1.2 + (2014-06-25, Carter Tazio Schonwald ) + * Fix space leak in recordShutdown + (2014-08-15, John Lato ) + +0.2.0 + + * Initial release + (2014-02-12, Edsko de Vries ) diff --git a/ghc-events-analyze.cabal b/ghc-events-analyze.cabal --- a/ghc-events-analyze.cabal +++ b/ghc-events-analyze.cabal @@ -1,5 +1,5 @@ name: ghc-events-analyze -version: 0.2.2 +version: 0.2.3 synopsis: Analyze and visualize event logs description: ghc-events-analyze is a simple Haskell profiling tool that uses GHC's eventlog system. It helps with some profiling @@ -51,16 +51,16 @@ GHC.RTS.Events.Analyze.Reports.Timed GHC.RTS.Events.Analyze.Reports.Timed.SVG - build-depends: base >= 4.5 && < 4.9, + build-depends: base >= 4.5 && < 4.10, ghc-events >= 0.4 && < 0.5, - optparse-applicative >= 0.11 && < 0.12, - diagrams-lib >= 1.2 && < 1.4, - diagrams-svg >= 1.1 && < 1.4, - SVGFonts >= 1.4 && < 1.6, + optparse-applicative >= 0.11 && < 0.14, + diagrams-lib >= 1.3 && < 1.4, + diagrams-svg >= 1.1 && < 1.5, + SVGFonts >= 1.5 && < 1.7, containers >= 0.5 && < 0.6, - lens >= 3.10 && < 4.13, + lens >= 3.10 && < 4.15, mtl >= 2.2.1 && < 2.3, - transformers >= 0.3 && < 0.5, + transformers >= 0.3 && < 0.6, filepath >= 1.3 && < 1.5, parsec >= 3.1 && < 3.2, th-lift >= 0.6 && < 0.8, diff --git a/src/GHC/RTS/Events/Analyze.hs b/src/GHC/RTS/Events/Analyze.hs --- a/src/GHC/RTS/Events/Analyze.hs +++ b/src/GHC/RTS/Events/Analyze.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE CPP #-} module Main where -import Control.Applicative ((<$>)) import Control.Monad (when, forM_) import System.FilePath (replaceExtension, takeFileName) import Text.Parsec.String (parseFromFile) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif import GHC.RTS.Events.Analyze.Analysis import GHC.RTS.Events.Analyze.Options diff --git a/src/GHC/RTS/Events/Analyze/Analysis.hs b/src/GHC/RTS/Events/Analyze/Analysis.hs --- a/src/GHC/RTS/Events/Analyze/Analysis.hs +++ b/src/GHC/RTS/Events/Analyze/Analysis.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, CPP #-} module GHC.RTS.Events.Analyze.Analysis ( -- * Auxiliary readEventLog -- * Basic analysis , events - , threadInfo - , numThreads , analyze -- * Using EventAnalysis , eventTotal @@ -15,17 +13,21 @@ ) where import Prelude hiding (log) -import Control.Applicative ((<$>), (<|>)) -import Control.Lens ((%=), (.=), use) -import Control.Monad (forM_, when) +import Control.Applicative ((<|>)) +import Control.Lens ((%=), (.=), at, use) +import Control.Monad (forM_, when, void) import Data.Char (isSpace, isDigit) import Data.Maybe (fromMaybe) import Data.Map.Strict (Map) import GHC.RTS.Events hiding (events) import qualified Data.Map.Strict as Map +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + import GHC.RTS.Events.Analyze.Utils -import GHC.RTS.Events.Analyze.StrictState (State, execState, put, modify, get, runState) +import GHC.RTS.Events.Analyze.StrictState (State, execState, put, get, runState) import GHC.RTS.Events.Analyze.Types import GHC.RTS.Events.Analyze.Script @@ -47,8 +49,8 @@ analyze :: Options -> EventLog -> [EventAnalysis] analyze opts@Options{..} log = - let analyses = execState (mapM_ analyzeEvent (sortedEvents log)) - [initialEventAnalysis opts] + let AnalysisState _ analyses = execState (mapM_ analyzeEvent (sortedEvents log)) + (initialAnalysisState opts) in reverse [ analysis { eventTotals = computeTotals (_events analysis) , eventStarts = computeStarts (_events analysis) } @@ -56,10 +58,10 @@ where isWindowEvent :: EventId -> Bool isWindowEvent = case optionsWindowEvent of - [] -> const False - nm -> (== parseGroupId nm) + Nothing -> const False + Just ev -> (== ev) - analyzeEvent :: Event -> State [EventAnalysis] () + analyzeEvent :: Event -> State AnalysisState () analyzeEvent (Event time spec) = do cur $ recordShutdown time case spec of @@ -70,45 +72,39 @@ Startup _numCaps -> cur $ recordStartup time Shutdown -> cur $ recordShutdown time -- Thread info - CreateThread tid -> cur $ recordThreadCreation tid time - (finishThread -> Just tid) -> cur $ recordThreadFinish tid time + CreateThread tid -> recordThreadCreation tid time + (finishThread -> Just tid) -> recordThreadFinish tid time -- Start/end events - ThreadLabel tid l -> cur $ labelThread tid l - (startId -> Just eid) -> cur $ do - ifInWindow $ recordEventStart eid time - when (isWindowEvent eid) $ do - startup .= Just time - inWindow .= True - (stopId -> Just eid) -> do when (isWindowEvent eid) $ do - cur $ do - inWindow .= False - recordShutdown time - modify (initialEventAnalysis opts :) + ThreadLabel tid l -> labelThread tid l + (startId -> Just eid) -> do cur $ ifInWindow $ recordEventStart eid time + when (isWindowEvent eid) $ recordWindowStart time + (stopId -> Just eid) -> do when (isWindowEvent eid) $ recordWindowStop opts time cur $ ifInWindow $ recordEventStop eid time _ -> return () startId :: EventInfo -> Maybe EventId startId (RunThread tid) = Just $ EventThread tid startId StartGC = Just $ EventGC - startId (UserMessage (prefix optionsUserStart -> Just e)) = Just $ parseGroupId e + startId (UserMessage (prefix optionsUserStart -> Just e)) = Just $ parseUserEvent e startId _ = Nothing stopId :: EventInfo -> Maybe EventId stopId (StopThread tid _) = Just $ EventThread tid stopId EndGC = Just $ EventGC - stopId (UserMessage (prefix optionsUserStop -> Just e)) = Just $ parseGroupId e + stopId (UserMessage (prefix optionsUserStop -> Just e)) = Just $ parseUserEvent e stopId _ = Nothing - ifInWindow m = do - b <- use inWindow - when b m +ifInWindow :: State EventAnalysis () -> State EventAnalysis () +ifInWindow m = do + b <- use inWindow + when b m -- Lift actions on the current analysis to the head of the list. -cur :: State EventAnalysis a -> State [EventAnalysis] a +cur :: State EventAnalysis a -> State AnalysisState a cur m = do - h:t <- get + AnalysisState ts (h:t) <- get case runState m h of - (r,h') -> put (h':t) >> return r + (r, h') -> put (AnalysisState ts (h':t)) >> return r -- We take the _first_ CapCreate to be the official startup time recordStartup :: Timestamp -> State EventAnalysis () @@ -119,12 +115,6 @@ recordShutdown time = shutdown %= (\prevt'm -> let newtime = maybe time (max time) prevt'm in newtime `seq` Just newtime) -parseGroupId :: String -> EventId -parseGroupId s = case ds of - [] -> EventUser s 0 - _ -> EventUser (dropWhile isSpace cs) (read ds) - where (ds,cs) = span isDigit s - recordEventStart :: EventId -> Timestamp -> State EventAnalysis () recordEventStart eid start = do (oldValue, newOpen) <- Map.insertLookupWithKey push eid (start, 1) <$> use openEvents @@ -171,38 +161,90 @@ EventThread _ -> (oldStart, count) EventUser _ _ -> (newStart, count) -recordThreadCreation :: ThreadId -> Timestamp -> State EventAnalysis () -recordThreadCreation tid start = - threadInfo tid .= Just (start, start, show tid) +recordWindowStart :: Timestamp -> State AnalysisState () +recordWindowStart time = do + cur $ do + startup .= Just time + inWindow .= True + -- Record creation of any threads that + -- were running before window was entered + recordRunningThreadCreation time -recordThreadFinish :: ThreadId -> Timestamp -> State EventAnalysis () +recordWindowStop :: Options -> Timestamp -> State AnalysisState () +recordWindowStop opts time = do + cur $ do + inWindow .= False + recordShutdown time + recordRunningThreadFinish time + windowAnalyses %= (initialEventAnalysis opts :) + +-- Record thread creation in current window, and add it to the map of running threads +recordThreadCreation :: ThreadId -> Timestamp -> State AnalysisState () +recordThreadCreation tid start = do + let label = show tid + cur $ ifInWindow $ recordWindowThreadCreation tid start label + runningThreads . at tid .= Just label + +-- Record thread creation in current window +recordWindowThreadCreation :: ThreadId -> Timestamp -> String -> State EventAnalysis () +recordWindowThreadCreation tid start label = + windowThreadInfo . at tid .= Just (start, start, label) + +-- Record the creation of all running threads in the current window +-- This should be used when entering a window +recordRunningThreadCreation :: Timestamp -> State AnalysisState () +recordRunningThreadCreation start = do + threads <- use runningThreads + void $ Map.traverseWithKey recordWindowCreation threads + where + recordWindowCreation tid label = cur $ recordWindowThreadCreation tid start label + +recordThreadFinish :: ThreadId -> Timestamp -> State AnalysisState () recordThreadFinish tid stop = do -- The "thread finished" doubles as a "thread stop" - recordEventStop (EventThread tid) stop - threadInfo tid %= fmap updStop + cur $ ifInWindow $ recordEventStop (EventThread tid) stop + cur $ ifInWindow $ recordWindowThreadFinish tid stop + runningThreads . at tid .= Nothing + +recordWindowThreadFinish :: ThreadId -> Timestamp -> State EventAnalysis () +recordWindowThreadFinish tid stop = + windowThreadInfo . at tid %= fmap updStop where updStop (start, _stop, l) = (start, stop, l) -labelThread :: ThreadId -> String -> State EventAnalysis () -labelThread tid l = - threadInfo tid %= fmap updLabel +recordRunningThreadFinish :: Timestamp -> State AnalysisState () +recordRunningThreadFinish stop = do + threads <- use runningThreads + mapM_ (\tid -> cur $ recordWindowThreadFinish tid stop) $ threadIds threads + +labelThread :: ThreadId -> String -> State AnalysisState () +labelThread tid l = do + runningThreads . at tid %= fmap updLabel + cur $ windowThreadInfo . at tid %= fmap updThreadInfo where - updLabel (start, stop, l') = (start, stop, l ++ " (" ++ l' ++ ")") + updThreadInfo (start, stop, l') = (start, stop, updLabel l') + updLabel l' = l ++ " (" ++ l' ++ ")" finishThread :: EventInfo -> Maybe ThreadId finishThread (StopThread tid ThreadFinished) = Just tid finishThread _ = Nothing +initialAnalysisState :: Options -> AnalysisState +initialAnalysisState opts = AnalysisState { + _runningThreads = Map.empty + , _windowAnalyses = [initialEventAnalysis opts] + } + initialEventAnalysis :: Options -> EventAnalysis initialEventAnalysis opts = EventAnalysis { - _events = [] - , __threadInfo = Map.empty - , _openEvents = Map.empty - , eventTotals = error "eventTotals computed at the end" - , eventStarts = error "eventStarts computed at the end" - , _startup = Nothing - , _shutdown = Nothing - , _inWindow = null (optionsWindowEvent opts) + _events = [] + , _windowThreadInfo = Map.empty + , _openEvents = Map.empty + , eventTotals = error "eventTotals computed at the end" + , eventStarts = error "eventStarts computed at the end" + , _startup = Nothing + , _shutdown = Nothing + , _inWindow = null (optionsWindowEvent opts) } computeTotals :: [(EventId, Timestamp, Timestamp)] -> Map EventId Timestamp @@ -257,7 +299,7 @@ quantize :: Int -> EventAnalysis -> Quantized quantize numBuckets EventAnalysis{..} = Quantized { quantTimes = go Map.empty _events - , quantThreadInfo = Map.map quantizeThreadInfo __threadInfo + , quantThreadInfo = Map.map quantizeThreadInfo _windowThreadInfo , quantBucketSize = bucketSize } where diff --git a/src/GHC/RTS/Events/Analyze/Options.hs b/src/GHC/RTS/Events/Analyze/Options.hs --- a/src/GHC/RTS/Events/Analyze/Options.hs +++ b/src/GHC/RTS/Events/Analyze/Options.hs @@ -1,10 +1,16 @@ +{-# LANGUAGE CPP #-} module GHC.RTS.Events.Analyze.Options ( Options(..) , parseOptions ) where +import Data.Foldable (asum) import Options.Applicative +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mconcat) +#endif + import GHC.RTS.Events.Analyze.Types import GHC.RTS.Events.Analyze.Script import GHC.RTS.Events.Analyze.Script.Standard @@ -12,67 +18,111 @@ parseOptions :: IO Options parseOptions = customExecParser (prefs showHelpOnError) opts where - opts = info (helper <*> parserOptions) - ( fullDesc - <> progDesc "Quantize and visualize EVENTLOG" - <> footer "If no output is selected, generates SVG and totals." - ) + opts = info (helper <*> parserOptions) $ mconcat [ + fullDesc + , progDesc "Quantize and visualize EVENTLOG" + , footer "If no output is selected, generates SVG and totals." + ] parserOptions :: Parser Options parserOptions = - infoOption scriptHelp ( long "help-script" - <> help "Detailed information about scripts" - ) - <*> (selectDefaultOutput <$> (Options - <$> switch ( long "timed" - <> help "Generate timed report (in SVG format)" - ) - <*> switch ( long "timed-txt" - <> help "Generate timed report (in textual format)" - ) - <*> switch ( long "totals" - <> help "Generate totals report" - ) - <*> strOption ( long "window" - <> metavar "NAME" - <> help "Events named NAME act to mark bounds of visualization window." - <> value "" - ) - <*> option auto( long "buckets" - <> short 'b' - <> metavar "INT" - <> help "Use INT buckets for quantization." - <> showDefault - <> value 1000 - ) - <*> strOption ( long "start" - <> metavar "STR" - <> help "Use STR as the prefix for the start of user events" - <> showDefault - <> value "START " - ) - <*> strOption ( long "stop" - <> metavar "STR" - <> help "Use STR as the prefix for the end of user events" - <> showDefault - <> value "STOP " - ) - <*> strOption ( long "script-totals" - <> metavar "PATH" - <> help "Use the script in PATH for the totals report" - <> value "" - ) - <*> strOption ( long "script-timed" - <> metavar "PATH" - <> help "Use the script in PATH for the timed reports" - <> value "" - ) - <*> switch ( long "ms" - <> help "Use milliseconds (rather than seconds) on SVG timeline" - ) - <*> argument str (metavar "EVENTLOG") - )) + (infoOption scriptHelp $ mconcat [ + long "help-script" + , help "Detailed information about scripts" + ]) + <*> (selectDefaultOutput <$> (Options + <$> (switch $ mconcat [ + long "timed" + , help "Generate timed report (in SVG format)" + ]) + <*> (switch $ mconcat [ + long "timed-txt" + , help "Generate timed report (in textual format)" + ]) + <*> (switch $ mconcat [ + long "totals" + , help "Generate totals report" + ]) + <*> (optional . option (parseUserEvent <$> str) $ mconcat [ + long "window" + , metavar "NAME" + , help "Events named NAME act to mark bounds of visualization window." + ]) + <*> (option auto $ mconcat [ + long "buckets" + , short 'b' + , metavar "INT" + , help "Use INT buckets for quantization." + , showDefault + , value 1000 + ]) + <*> (strOption $ mconcat [ + long "start" + , metavar "STR" + , help "Use STR as the prefix for the start of user events" + , showDefault + , value "START " + ]) + <*> (strOption $ mconcat [ + long "stop" + , metavar "STR" + , help "Use STR as the prefix for the end of user events" + , showDefault + , value "STOP " + ]) + <*> (strOption $ mconcat [ + long "script-totals" + , metavar "PATH" + , help "Use the script in PATH for the totals report" + , value "" + ]) + <*> (strOption $ mconcat [ + long "script-timed" + , metavar "PATH" + , help "Use the script in PATH for the timed reports" + , value "" + ]) + <*> parseTimelineGranularity + <*> (option auto $ mconcat [ + long "tick-every" + , metavar "N" + , help "Render a tick every N buckets" + , value 1 + , showDefault + ]) + <*> (option auto $ mconcat [ + long "bucket-width" + , metavar "DOUBLE" + , help "Width of every bucket" + , value 14 + , showDefault + ]) + <*> (option auto $ mconcat [ + long "bucket-height" + , metavar "DOUBLE" + , help "Height of every bucket" + , value 14 + , showDefault + ]) + <*> (option auto $ mconcat [ + long "border-width" + , metavar "DOUBLE" + , help "Width of the border around each bucket (set to 0 for none)" + , value 0.1 + , showDefault + ]) + <*> argument str (metavar "EVENTLOG") + )) +parseTimelineGranularity :: Parser TimelineGranularity +parseTimelineGranularity = asum [ + flag' TimelineMilliseconds $ mconcat [ + long "ms" + , help "Use milliseconds (rather than seconds) on SVG timeline" + ] + , pure TimelineSeconds + ] + scriptHelp :: String scriptHelp = unlines [ "Scripts are used to drive report generation. The syntax for scripts is" @@ -82,7 +132,7 @@ , " ::= \"section\" STRING" , " | (\"as\" STRING)?" , " | \"sum\" (\"as\" STRING)?" - , " | (\"by\" )?" + , " | \"all\" (\"by\" )?" , "" , " ::= STRING -- user event" , " | INT -- thread event" @@ -95,6 +145,7 @@ , "" , " ::= \"total\"" , " | \"name\"" + , " | \"start\"" , "" , "The default script for the timed reports is\n" ] diff --git a/src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs b/src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs --- a/src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs +++ b/src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs @@ -5,25 +5,19 @@ ) where import Data.Maybe (catMaybes) -import Data.Monoid (mempty, mconcat, (<>)) +import Data.Monoid ((<>)) import Diagrams.Backend.SVG (B, renderSVG) -#if MIN_VERSION_diagrams_lib(1,3,0) import Diagrams.Prelude (QDiagram, Colour, V2, N, Any, (#), (|||)) -#else -import Diagrams.Prelude (Diagram, Colour, R2, (#), (|||)) -#endif import GHC.RTS.Events (Timestamp) +import Graphics.SVGFonts.Text (TextOpts(..)) import Text.Printf (printf) -import qualified Data.Map as Map +import qualified Data.Map as Map import qualified Diagrams.Prelude as D - -#if MIN_VERSION_SVGFonts(1,5,0) -import Graphics.SVGFonts.Text (TextOpts(..)) -import qualified Graphics.SVGFonts.Text as F import qualified Graphics.SVGFonts.Fonts as F -#else -import Graphics.SVGFonts.ReadFont (TextOpts(..)) -import qualified Graphics.SVGFonts.ReadFont as F +import qualified Graphics.SVGFonts.Text as F + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mempty, mconcat) #endif import GHC.RTS.Events.Analyze.Types @@ -33,26 +27,18 @@ writeReport options quantized report path = uncurry (renderSVG path) $ renderReport options quantized report -#if MIN_VERSION_diagrams_lib(1,3,0) -type D = QDiagram B V2 (N B) Any +type D = QDiagram B V2 (N B) Any type SizeSpec = D.SizeSpec V2 Double -#else -type D = Diagram B R2 -type SizeSpec = D.SizeSpec2D -#endif renderReport :: Options -> Quantized -> Report -> (SizeSpec, D) -renderReport Options{optionsNumBuckets, optionsMilliseconds} +renderReport options@Options{..} Quantized{quantBucketSize} - report = (sizeSpec, rendered) + report + = (sizeSpec, rendered) where -#if MIN_VERSION_diagrams_lib(1,3,0) - sizeSpec = let w = Just $ D.width rendered + sizeSpec = let w = Just $ D.width rendered h = Just $ D.height rendered in D.mkSizeSpec2D w h -#else - sizeSpec = D.sizeSpec2D rendered -#endif rendered :: D rendered = D.vcat $ map (uncurry renderSVGFragment) @@ -60,51 +46,52 @@ (SVGTimeline : fragments) fragments :: [SVGFragment] - fragments = map renderFragment $ zip report (cycle allColors) + fragments = map (renderFragment options) $ zip report (cycle allColors) renderSVGFragment :: Colour Double -> SVGFragment -> D renderSVGFragment _ (SVGSection title) = - padHeader (2 * blockSize) title + padHeader (2 * optionsBucketHeight) title renderSVGFragment bg (SVGLine header blocks) = -- Add empty block at the start so that the whole thing doesn't shift up - (padHeader blockSize header ||| (blocks <> (block 0 # D.lw D.none))) + (padHeader optionsBucketHeight header ||| (blocks <> (block options 0 # D.lw D.none))) `D.atop` - (D.rect lineWidth blockHeight # D.alignL # D.fc bg # D.lw D.none) + (D.rect lineWidth optionsBucketHeight # D.alignL # D.fc bg # D.lw D.none) renderSVGFragment _ SVGTimeline = - padHeader blockSize mempty - ||| timeline granularity optionsNumBuckets quantBucketSize + padHeader optionsBucketHeight mempty + ||| timeline options optionsNumBuckets quantBucketSize - lineWidth = headerWidth + fromIntegral optionsNumBuckets * blockWidth + lineWidth :: Double + lineWidth = headerWidth + fromIntegral optionsNumBuckets * optionsBucketWidth padHeader :: Double -> D -> D padHeader height h = - D.translateX (0.5 * blockSize) h + D.translateX (0.5 * optionsBucketWidth) h <> D.rect headerWidth height # D.alignL # D.lw D.none headerWidth :: Double - headerWidth = blockSize -- extra padding + headerWidth = optionsBucketWidth -- extra padding + (maximum . catMaybes . map headerWidthOf $ fragments) headerWidthOf :: SVGFragment -> Maybe Double headerWidthOf (SVGLine header _) = Just (D.width header) headerWidthOf _ = Nothing - granularity = if optionsMilliseconds then TimelineMilliseconds - else TimelineSeconds - data SVGFragment = SVGTimeline | SVGSection D | SVGLine D D -renderFragment :: (ReportFragment, Colour Double) -> SVGFragment -renderFragment (ReportSection title,_) = SVGSection (renderText title (blockSize + 2)) -renderFragment (ReportLine line,c) = uncurry SVGLine $ renderLine c line +renderFragment :: Options -> (ReportFragment, Colour Double) -> SVGFragment +renderFragment options@Options{..} = go + where + go :: (ReportFragment, Colour Double) -> SVGFragment + go (ReportSection title,_) = SVGSection (renderText title (optionsBucketHeight + 2)) + go (ReportLine line,c) = uncurry SVGLine $ renderLine options c line -renderLine :: Colour Double -> ReportLine -> (D, D) -renderLine lc line@ReportLineData{..} = - ( renderText lineHeader (blockSize + 2) - , blocks lc <> bgBlocks lineBackground +renderLine :: Options -> Colour Double -> ReportLine -> (D, D) +renderLine options@Options{..} lc line@ReportLineData{..} = + ( renderText lineHeader (optionsBucketHeight + 2) + , blocks lc <> bgBlocks options lineBackground ) where blocks :: Colour Double -> D @@ -112,7 +99,7 @@ $ Map.toList lineValues mkBlock :: Colour Double -> (Int, Double) -> D - mkBlock c (b, q) = block b # D.fcA (c `D.withOpacity` qOpacity q) + mkBlock c (b, q) = block options b # D.fcA (c `D.withOpacity` qOpacity q) lineColor :: Colour Double -> ReportLine -> Colour Double lineColor c = eventColor c . head . lineEventIds @@ -122,35 +109,26 @@ eventColor c (EventUser _ _) = c eventColor _ (EventThread _) = D.blue -bgBlocks :: Maybe (Int, Int) -> D -bgBlocks Nothing = mempty -bgBlocks (Just (fr, to)) = mconcat [ - block b # D.fcA (D.black `D.withOpacity` 0.1) - | b <- [fr .. to] - ] +bgBlocks :: Options -> Maybe (Int, Int) -> D +bgBlocks options = go + where + go :: Maybe (Int, Int) -> D + go Nothing = mempty + go (Just (fr, to)) = mconcat [ + block options b # D.fcA (D.black `D.withOpacity` 0.1) + | b <- [fr .. to] + ] renderText :: String -> Double -> D renderText str size = D.stroke textSVG # D.fc D.black # D.lc D.black # D.alignL # D.lw D.none where -#if MIN_VERSION_SVGFonts(1,5,0) textSVG = F.textSVG' (textOpts size) str -#else - textSVG = F.textSVG' (textOpts str size) -#endif -#if MIN_VERSION_SVGFonts(1,5,0) textOpts :: Double -> TextOpts Double textOpts size = TextOpts { textFont = F.lin -#else -textOpts :: String -> Double -> TextOpts -textOpts str size = - TextOpts { - txt = str - , fdo = F.lin -#endif , mode = F.INSIDE_H , spacing = F.KERN , underline = False @@ -172,57 +150,54 @@ qOpacity 0 = 0 qOpacity q = 0.3 + q * 0.7 -block :: Int -> D -block i = D.translateX (blockWidth * fromIntegral i) - $ D.rect blockWidth blockHeight # D.lw D.none - -blockSize :: Double -blockSize = blockHeight - -blockWidth :: Double -blockWidth = 2 - -blockHeight :: Double -blockHeight = 14 - -data TimelineGranularity = TimelineSeconds | TimelineMilliseconds +block :: Options -> Int -> D +block Options{..} i = + D.translateX (optionsBucketWidth * fromIntegral i) + $ D.rect optionsBucketWidth optionsBucketHeight # D.lw borderWidth + where + borderWidth | optionsBorderWidth == 0 = D.none + | otherwise = D.global optionsBorderWidth -timeline :: TimelineGranularity -> Int -> Timestamp -> D -timeline granularity numBuckets bucketSize = - mconcat [ timelineBlock b # D.translateX (fromIntegral b * blockWidth) - | b <- [0 .. numBuckets - 1] - , b `mod` blockMod == 0 +timeline :: Options -> Int -> Timestamp -> D +timeline Options{..} numBuckets bucketSize = + mconcat [ timelineBlock b # D.translateX (fromIntegral tb * timelineBlockWidth) + | -- bucket number + b <- [0 .. numBuckets - 1] + -- timeline block number, index within this timeline block @(0 .. optionsTickEvery - 1)@ + , let (tb, tidx) = b `divMod` optionsTickEvery + -- we show the timeline block when the index is 0 + , tidx == 0 ] where - blockMod = 10 `div` (round blockWidth) - timelineBlock b - | b `rem` (5 * blockMod) == 0 - = D.strokeLine bigLine # D.lw (localMeasure 0.5) - <> (renderText (bucketTime b) blockHeight # D.translateY (blockHeight - 2)) + timelineBlockWidth :: Double + timelineBlockWidth = fromIntegral optionsTickEvery * optionsBucketWidth + + -- Single block on the time-line; every 5 blocks a larger line and a time + -- label; for the remainder just a shorter line + timelineBlock :: Int -> D + timelineBlock tb + | tb `rem` 5 == 0 + = D.strokeLine bigLine # D.lw (D.local 0.5) + <> (renderText (bucketTime tb) optionsBucketHeight # D.translateY (optionsBucketHeight - 2)) | otherwise - = D.strokeLine smallLine # D.lw (localMeasure 0.5) # D.translateY 1 -#if MIN_VERSION_diagrams_lib(1,3,0) - localMeasure = D.local -#else - localMeasure = D.Local -#endif + = D.strokeLine smallLine # D.lw (D.local 0.5) # D.translateY 1 bucketTime :: Int -> String - bucketTime b = let timeNs :: Timestamp - timeNs = fromIntegral b * bucketSize - - timeS :: Double - timeS = fromIntegral timeNs / 1000000000 + bucketTime tb = case optionsGranularity of + TimelineMilliseconds -> printf "%0.1fms" timeMS + TimelineSeconds -> printf "%0.1fs" timeS + where + timeNs :: Timestamp + timeNs = fromIntegral (tb * optionsTickEvery) * bucketSize - timeMS :: Double - timeMS = fromIntegral timeNs / 1000000 + timeS :: Double + timeS = fromIntegral timeNs / 1000000000 - in case granularity of - TimelineMilliseconds -> printf "%0.1fms" timeMS - TimelineSeconds -> printf "%0.1fs" timeS + timeMS :: Double + timeMS = fromIntegral timeNs / 1000000 - bigLine = mkLine [(0, 4), (10, 0)] - smallLine = mkLine [(0, 3), (10, 0)] + bigLine = mkLine [(0, 4), (timelineBlockWidth, 0)] + smallLine = mkLine [(0, 3), (timelineBlockWidth, 0)] mkLine = D.fromSegments . map (D.straight . D.r2) -- copied straight out of export list for Data.Colour.Names diff --git a/src/GHC/RTS/Events/Analyze/Reports/Totals.hs b/src/GHC/RTS/Events/Analyze/Reports/Totals.hs --- a/src/GHC/RTS/Events/Analyze/Reports/Totals.hs +++ b/src/GHC/RTS/Events/Analyze/Reports/Totals.hs @@ -55,7 +55,7 @@ reportLine :: Maybe Title -> (EventId, Timestamp) -> ReportLine reportLine title (eid, total) = ReportLineData { - lineHeader = showTitle (showEventId __threadInfo eid) title + lineHeader = showTitle (showEventId _windowThreadInfo eid) title , lineEventIds = [eid] , lineTotal = total } diff --git a/src/GHC/RTS/Events/Analyze/Script.hs b/src/GHC/RTS/Events/Analyze/Script.hs --- a/src/GHC/RTS/Events/Analyze/Script.hs +++ b/src/GHC/RTS/Events/Analyze/Script.hs @@ -17,11 +17,7 @@ , scriptQQ ) where -import Control.Applicative ((<$>), (<*>), (*>), (<*), pure) import Data.List (intercalate) -#if !MIN_VERSION_template_haskell(2,10,0) -import Data.Word (Word32) -#endif import Language.Haskell.TH.Lift (deriveLiftMany) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax @@ -29,6 +25,14 @@ import Text.Parsec.Language (haskellDef) import qualified Text.Parsec.Token as P +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>), (*>), (<*), pure) +#endif + +#if !MIN_VERSION_template_haskell(2,10,0) +import Data.Word (Word32) +#endif + import GHC.RTS.Events.Analyze.Types {------------------------------------------------------------------------------- @@ -156,10 +160,24 @@ {------------------------------------------------------------------------------- Syntax analysis + + NOTE: If updating the grammar here should also update the BNF description + in 'scriptHelp' (@--help-script@). + + NOTE: Make sure parser and unparser are consistent with each other. -------------------------------------------------------------------------------} type Parser a = Parsec String () a +pScript :: Parser Script +pScript = whiteSpace *> many1 pCommand <* eof + +pCommand :: Parser Command +pCommand = (Section <$> (reserved "section" *> stringLiteral)) + <|> (One <$> pEventId <*> pTitle) + <|> (Sum <$> (reserved "sum" *> pEventFilter) <*> pTitle) + <|> (All <$> (reserved "all" *> pEventFilter) <*> pEventSort) + pEventId :: Parser EventId pEventId = (EventUser <$> stringLiteral <*> pure 0 "user event") <|> (EventThread <$> pThreadId "thread event") @@ -173,12 +191,6 @@ <|> (const IsThread <$> reserved "thread") <|> (Any <$> (squares $ commaSep1 pEventFilter)) -pCommand :: Parser Command -pCommand = (Section <$> (reserved "section" *> stringLiteral)) - <|> (One <$> pEventId <*> pTitle) - <|> (Sum <$> (reserved "sum" *> pEventFilter) <*> pTitle) - <|> (All <$> (reserved "all" *> pEventFilter) <*> pEventSort) - pEventSort :: Parser (Maybe EventSort) pEventSort = optionMaybe $ reserved "by" *> ( (const SortByTotal <$> reserved "total") @@ -189,9 +201,40 @@ pTitle :: Parser (Maybe Title) pTitle = optionMaybe (reserved "as" *> stringLiteral) -pScript :: Parser Script -pScript = whiteSpace *> many1 pCommand <* eof +{------------------------------------------------------------------------------- + Unparsing +-------------------------------------------------------------------------------} +unparseScript :: Script -> [String] +unparseScript = concatMap unparseCommand + +unparseCommand :: Command -> [String] +unparseCommand (Section title) = ["", "section " ++ show title] +unparseCommand (One eid title) = [unparseEventId eid ++ " " ++ unparseTitle title] +unparseCommand (Sum f title) = ["sum " ++ unparseFilter f ++ " " ++ unparseTitle title] +unparseCommand (All f sort) = ["all " ++ unparseFilter f ++ " " ++ unparseSort sort] + +unparseEventId :: EventId -> String +unparseEventId EventGC = "GC" +unparseEventId (EventUser e _) = show e +unparseEventId (EventThread tid) = show tid + +unparseFilter :: EventFilter -> String +unparseFilter (Is eid) = unparseEventId eid +unparseFilter IsUser = "user" +unparseFilter IsThread = "thread" +unparseFilter (Any fs) = "[" ++ intercalate "," (map unparseFilter fs) ++ "]" + +unparseSort :: Maybe EventSort -> String +unparseSort Nothing = "" +unparseSort (Just SortByName) = "by name" +unparseSort (Just SortByTotal) = "by total" +unparseSort (Just SortByStart) = "by start" + +unparseTitle :: Maybe Title -> String +unparseTitle Nothing = "" +unparseTitle (Just t) = "as " ++ show t + {------------------------------------------------------------------------------- Quasi-quoting -------------------------------------------------------------------------------} @@ -216,37 +259,3 @@ case runParser pScript () source input of Left err -> fail (show err) Right script -> return script - -{------------------------------------------------------------------------------- - Unparsing --------------------------------------------------------------------------------} - -unparseScript :: Script -> [String] -unparseScript = concatMap unparseCommand - -unparseCommand :: Command -> [String] -unparseCommand (Section title) = ["", title] -unparseCommand (One eid title) = [unparseEventId eid ++ " " ++ unparseTitle title] -unparseCommand (All f sort) = ["all " ++ unparseFilter f ++ " " ++ unparseSort sort] -unparseCommand (Sum f title) = ["sum " ++ unparseFilter f ++ " " ++ unparseTitle title] - -unparseEventId :: EventId -> String -unparseEventId EventGC = "GC" -unparseEventId (EventUser e _) = e -unparseEventId (EventThread tid) = show tid - -unparseTitle :: Maybe Title -> String -unparseTitle Nothing = "" -unparseTitle (Just t) = "as " ++ t - -unparseSort :: Maybe EventSort -> String -unparseSort Nothing = "" -unparseSort (Just SortByName) = "by name" -unparseSort (Just SortByTotal) = "by total" -unparseSort (Just SortByStart) = "by start" - -unparseFilter :: EventFilter -> String -unparseFilter (Is eid) = unparseEventId eid -unparseFilter IsUser = "user" -unparseFilter IsThread = "thread" -unparseFilter (Any fs) = "[" ++ intercalate "," (map unparseFilter fs) ++ "]" diff --git a/src/GHC/RTS/Events/Analyze/StrictState.hs b/src/GHC/RTS/Events/Analyze/StrictState.hs --- a/src/GHC/RTS/Events/Analyze/StrictState.hs +++ b/src/GHC/RTS/Events/Analyze/StrictState.hs @@ -1,5 +1,5 @@ -- | State monad which forces the state to whnf on every step -{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, CPP #-} module GHC.RTS.Events.Analyze.StrictState ( -- * Transformer StateT @@ -16,12 +16,15 @@ , module Control.Monad.State.Strict ) where -import Control.Applicative import Control.Monad.IO.Class (MonadIO) import Control.Monad.State.Strict (MonadState(..)) import qualified Control.Monad.State.Strict as St import Control.Monad.Trans.Class (MonadTrans) import Control.Monad.Identity (Identity(..)) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif {------------------------------------------------------------------------------- Transformer diff --git a/src/GHC/RTS/Events/Analyze/Types.hs b/src/GHC/RTS/Events/Analyze/Types.hs --- a/src/GHC/RTS/Events/Analyze/Types.hs +++ b/src/GHC/RTS/Events/Analyze/Types.hs @@ -1,27 +1,45 @@ {-# LANGUAGE TemplateHaskell #-} module GHC.RTS.Events.Analyze.Types ( + -- * Events EventId(..) + , SortIndex + , isUserEvent + , isThreadEvent + , parseUserEvent + , showEventId + -- * Options + , TimelineGranularity(..) , Options(..) + -- * Analysis state + , RunningThreads + , threadIds + , ThreadInfo , EventAnalysis(..) + , AnalysisState(..) + -- ** EventAnalysis lenses , events - , threadInfo + , windowThreadInfo , openEvents , startup , shutdown - , numThreads , inWindow + -- ** AnalysisState lenses + , runningThreads + , windowAnalyses + -- * Analysis result , Quantized(..) - , GroupId - , showEventId - , isUserEvent - , isThreadEvent ) where -import Control.Lens (Lens', makeLenses, at, (^.)) +import Control.Lens (makeLenses) +import Data.Char import Data.Map (Map) import GHC.RTS.Events (Timestamp, ThreadId) import qualified Data.Map as Map +{------------------------------------------------------------------------------- + Event identifiers +-------------------------------------------------------------------------------} + -- | Event identifiers -- -- The order of the constructors matters because it dictates the default @@ -37,34 +55,101 @@ -- > traceEventIO "START