ghc-events-analyze 0.2.2 → 0.2.3
raw patch · 10 files changed
+511/−325 lines, 10 filesdep ~SVGFontsdep ~basedep ~diagrams-lib
Dependency ranges changed: SVGFonts, base, diagrams-lib, diagrams-svg, lens, optparse-applicative, transformers
Files
- ChangeLog +37/−4
- ghc-events-analyze.cabal +8/−8
- src/GHC/RTS/Events/Analyze.hs +5/−1
- src/GHC/RTS/Events/Analyze/Analysis.hs +100/−58
- src/GHC/RTS/Events/Analyze/Options.hs +109/−58
- src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs +81/−106
- src/GHC/RTS/Events/Analyze/Reports/Totals.hs +1/−1
- src/GHC/RTS/Events/Analyze/Script.hs +55/−46
- src/GHC/RTS/Events/Analyze/StrictState.hs +5/−2
- src/GHC/RTS/Events/Analyze/Types.hs +110/−41
ChangeLog view
@@ -1,7 +1,40 @@-2014-09-23 Will Sewell <will@pusher.com>+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 <edsko@well-typed.com>)+ * Fix issue with thread creation before window start+ (2015-09-29, Will Sewell <will@pusher.com>)+ * Bump optparse-applicative and lens versions+ (2015-01-19, Will Sewell <will@pusher.com>) -2014-02-12 Edsko de Vries <edsko@well-typed.com>+0.2.2 - * Initial release + * Adds support for GHC 7.10+ (2015-09-23, Will Sewell <will@pusher.com>)+ (2015-05-29, GaneshRapolu <grapolu@berkeley.edu>)++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 <anfarmer@fb.com>)+ * 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 <v.dijk.bas@gmail.com>)+ * Relax bounds+ (2014-05-28, Dominic Steinitz <dominic@steinitz.org>)+ (2014-11-05, Alexander Vershilov <alexander.vershilov@gmail.com>)+ (2014-11-07, Andrew Farmer <anfarmer@fb.com>)+ * Move to diagrams 1.2+ (2014-06-25, Carter Tazio Schonwald <carter.schonwald@gmail.com>)+ * Fix space leak in recordShutdown+ (2014-08-15, John Lato <jwlato@tsurucapital.com>)++0.2.0++ * Initial release+ (2014-02-12, Edsko de Vries <edsko@well-typed.com>)
ghc-events-analyze.cabal view
@@ -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,
src/GHC/RTS/Events/Analyze.hs view
@@ -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
src/GHC/RTS/Events/Analyze/Analysis.hs view
@@ -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
src/GHC/RTS/Events/Analyze/Options.hs view
@@ -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 @@ , "<command> ::= \"section\" STRING" , " | <eventId> (\"as\" STRING)?" , " | \"sum\" <filter> (\"as\" STRING)?"- , " | <filter> (\"by\" <sort>)?"+ , " | \"all\" <filter> (\"by\" <sort>)?" , "" , "<eventId> ::= STRING -- user event" , " | INT -- thread event"@@ -95,6 +145,7 @@ , "" , "<sort> ::= \"total\"" , " | \"name\""+ , " | \"start\"" , "" , "The default script for the timed reports is\n" ]
src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs view
@@ -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
src/GHC/RTS/Events/Analyze/Reports/Totals.hs view
@@ -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 }
src/GHC/RTS/Events/Analyze/Script.hs view
@@ -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) ++ "]"
src/GHC/RTS/Events/Analyze/StrictState.hs view
@@ -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
src/GHC/RTS/Events/Analyze/Types.hs view
@@ -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 <label>" -- > ... -- > traceEventIO "STOP <label>"- | EventUser String GroupId+ | EventUser String SortIndex -- | Threads | EventThread ThreadId deriving (Eq, Ord, Show) -type GroupId = Int+-- | Sort index+--+-- Events can have an optional sort index, which can be used to control the+-- order in which events are sorted (the sort index itself is not shown+-- in the reports). To use this, simply use+--+-- > traceEventIO "START <sortIndex> <label>"+-- > ...+-- > traceEventIO "STOP <sortIndex> <label>"+type SortIndex = Int +isUserEvent :: EventId -> Bool+isUserEvent (EventUser{}) = True+isUserEvent _ = False++isThreadEvent :: EventId -> Bool+isThreadEvent (EventThread _) = True+isThreadEvent _ = False++-- | Parse user event+--+-- If the event name starts with a digit, regard it as a 'SortIndex'.+parseUserEvent :: String -> EventId+parseUserEvent s =+ case span isDigit s of+ ([], _ ) -> EventUser s 0+ (ds, cs) -> EventUser (dropWhile isSpace cs) (read ds)++-- | Show an event ID given thread info+--+-- The argument is typically either `__threadInfo` from `EventAnalysis` or+-- `quantThreadInfo` from `Quantized`.+showEventId :: Map ThreadId (a, a, String) -> EventId -> String+showEventId _ EventGC = "GC"+showEventId _ (EventUser event _) = event+showEventId info (EventThread tid) = case Map.lookup tid info of+ Just (_, _, l) -> l+ Nothing -> show tid++{-------------------------------------------------------------------------------+ Options+-------------------------------------------------------------------------------}++data TimelineGranularity = TimelineSeconds | TimelineMilliseconds+ deriving Show+ -- | Command line options data Options = Options { optionsGenerateTimedSVG :: Bool , optionsGenerateTimedText :: Bool , optionsGenerateTotalsText :: Bool- , optionsWindowEvent :: String+ , optionsWindowEvent :: Maybe EventId , optionsNumBuckets :: Int , optionsUserStart :: String , optionsUserStop :: String , optionsScriptTotals :: FilePath -- "" denotes the standard script , optionsScriptTimed :: FilePath- , optionsMilliseconds :: Bool+ , optionsGranularity :: TimelineGranularity+ , optionsTickEvery :: Int+ , optionsBucketWidth :: Double+ , optionsBucketHeight :: Double+ , optionsBorderWidth :: Double -- '0' for no border -- Defined last to make defining the parser easier , optionsInput :: FilePath } deriving Show +{-------------------------------------------------------------------------------+ Analysis state+-------------------------------------------------------------------------------}++-- | Map of currently running threads to their labels+type RunningThreads = Map ThreadId String++threadIds :: RunningThreads -> [ThreadId]+threadIds = Map.keys++-- | Information about each thread to be stored per window+--+-- When was the thread created, when was it destroyed, and what is the+-- thread label (as indicated by ThreadLabel events)+--+-- The default label for each thread is the thread ID+type ThreadInfo = Map ThreadId (Timestamp, Timestamp, String)++-- | Analysis of a window (or the whole program run if there aren't any). -- The fields that we use as "accumulators" in `analyze` are strict so that we -- don't build up chains of EventAnalysis objects when we update it as we--- process the eventlog+-- process the eventlog. data EventAnalysis = EventAnalysis { -- | Start and stop timestamps --@@ -72,13 +157,8 @@ -- be equal to the @start@ timestamp _events :: ![(EventId, Timestamp, Timestamp)] - -- | Information about each thread- --- -- When was the thread created, when was it destroyed, and what is the- -- thread label (as indicated by ThreadLabel events)- --- -- The default label for each thread is the thread ID- , __threadInfo :: !(Map ThreadId (Timestamp, Timestamp, String))+ -- | Window-specific thread info+ , _windowThreadInfo :: ThreadInfo -- | Event with a start but with a missing end. --@@ -113,12 +193,19 @@ $(makeLenses ''EventAnalysis) -threadInfo :: ThreadId -> Lens' EventAnalysis (Maybe (Timestamp, Timestamp, String))-threadInfo tid = _threadInfo . at tid+-- | State while running an analysis. Keeps track of currently running threads,+-- and appends an 'EventAnalysis' per window.+data AnalysisState = AnalysisState {+ _runningThreads :: RunningThreads+ , _windowAnalyses :: [EventAnalysis]+} -numThreads :: EventAnalysis -> Int-numThreads analysis = Map.size (analysis ^. _threadInfo)+$(makeLenses ''AnalysisState) +{-------------------------------------------------------------------------------+ Analysis result+-------------------------------------------------------------------------------}+ -- | Quantization splits the total time up into @n@ buckets. We record for each -- event and each bucket what percentage of that bucket the event used. A -- missing entry denotes 0.@@ -137,21 +224,3 @@ , quantBucketSize :: Timestamp } deriving Show---- | Show an event ID given the specified options (for renaming events)--- and information about threads (either `__threadInfo` from `EventAnalysis` or--- `quantThreadInfo` from `Quantized`).-showEventId :: Map ThreadId (a, a, String) -> EventId -> String-showEventId _ EventGC = "GC"-showEventId _ (EventUser event _) = event-showEventId info (EventThread tid) = case Map.lookup tid info of- Just (_, _, l) -> l- Nothing -> show tid--isUserEvent :: EventId -> Bool-isUserEvent (EventUser{}) = True-isUserEvent _ = False--isThreadEvent :: EventId -> Bool-isThreadEvent (EventThread _) = True-isThreadEvent _ = False