diff --git a/ghc-events-analyze.cabal b/ghc-events-analyze.cabal --- a/ghc-events-analyze.cabal +++ b/ghc-events-analyze.cabal @@ -1,6 +1,6 @@ name: ghc-events-analyze -version: 0.2.0 -synopsis: Analyze and visualize event logs +version: 0.2.1 +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 use cases that are not covered by the existing GHC @@ -19,7 +19,11 @@ profiling mode is not available, or when using profiling mode would perturb the code too much. It is also useful when you want time-profiling information with a breakdown - over time rather than totals for the whole run. + over time rather than totals for the whole run. + . + The blog post + + describes the motivation in more detail. license: BSD3 license-file: LICENSE author: Edsko de Vries, Duncan Coutts, Mikolaj Konarski @@ -31,10 +35,10 @@ cabal-version: >=1.10 source-repository head - type: git - location: https://github.com/edsko/ghc-events-analyze + type: git + location: https://github.com/edsko/ghc-events-analyze -executable ghc-events-analyze +executable ghc-events-analyze main-is: GHC/RTS/Events/Analyze.hs other-modules: GHC.RTS.Events.Analyze.Analysis GHC.RTS.Events.Analyze.Options @@ -47,19 +51,19 @@ GHC.RTS.Events.Analyze.Reports.Timed GHC.RTS.Events.Analyze.Reports.Timed.SVG - build-depends: base >= 4.5 && < 4.8, - ghc-events >= 0.4 && < 0.5, - optparse-applicative >= 0.7 && < 0.8, - diagrams-lib >= 1.0 && < 1.1, - diagrams-svg >= 1.0 && < 1.1, - SVGFonts >= 1.4 && < 1.5, - containers >= 0.5 && < 0.6, - lens >= 3.10 && < 4.1, - mtl >= 2.1 && < 2.2, - transformers >= 0.3 && < 0.4, - filepath >= 1.3 && < 1.4, - parsec >= 3.1 && < 3.2, - th-lift >= 0.6 && < 0.7, + build-depends: base >= 4.5 && < 4.8, + ghc-events >= 0.4 && < 0.5, + optparse-applicative >= 0.11 && < 0.12, + diagrams-lib >= 1.2 && < 1.3, + diagrams-svg >= 1.1 && < 1.3, + SVGFonts >= 1.4 && < 1.5, + containers >= 0.5 && < 0.6, + lens >= 3.10 && < 4.5, + mtl >= 2.2.1 && < 2.3, + transformers >= 0.3 && < 0.5, + filepath >= 1.3 && < 1.4, + parsec >= 3.1 && < 3.2, + th-lift >= 0.6 && < 0.7, -- No version: whatever is bundled with ghc template-haskell 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,7 +1,7 @@ module Main where import Control.Applicative ((<$>)) -import Control.Monad (when) +import Control.Monad (when, forM_) import System.FilePath (replaceExtension, takeFileName) import Text.Parsec.String (parseFromFile) @@ -16,15 +16,11 @@ main :: IO () main = do options@Options{..} <- parseOptions - analysis <- analyze options <$> readEventLog optionsInput + analyses <- analyze options <$> readEventLog optionsInput (timedScriptName, timedScript) <- getScript optionsScriptTimed defaultScriptTimed (totalsScriptName, totalsScript) <- getScript optionsScriptTotals defaultScriptTotals - let quantized = quantize optionsNumBuckets analysis - totals = Totals.createReport analysis totalsScript - timed = Timed.createReport analysis quantized timedScript - let writeReport :: Bool -> String -> String @@ -38,17 +34,31 @@ mkReport output putStrLn $ "Generated " ++ output ++ " using " ++ scriptName - writeReport optionsGenerateTotalsText - totalsScriptName - "totals.txt" $ Totals.writeReport totals + prefixAnalysisNumber :: Int -> String -> String + prefixAnalysisNumber i filename + | null optionsWindowEvent = filename + | otherwise = show i ++ "." ++ filename - writeReport optionsGenerateTimedSVG - timedScriptName - "timed.svg" $ TimedSVG.writeReport options quantized timed + forM_ (zip [0..] analyses) $ \ (i,analysis) -> do - writeReport optionsGenerateTimedText - timedScriptName - "timed.txt" $ Timed.writeReport timed + let quantized = quantize optionsNumBuckets analysis + totals = Totals.createReport analysis totalsScript + timed = Timed.createReport analysis quantized timedScript + + writeReport optionsGenerateTotalsText + totalsScriptName + (prefixAnalysisNumber i "totals.txt") + (Totals.writeReport totals) + + writeReport optionsGenerateTimedSVG + timedScriptName + (prefixAnalysisNumber i "timed.svg") + (TimedSVG.writeReport options quantized timed) + + writeReport optionsGenerateTimedText + timedScriptName + (prefixAnalysisNumber i "timed.txt") + (Timed.writeReport timed) getScript :: FilePath -> Script -> IO (String, Script) getScript "" def = return ("default script", def) 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 @@ -13,17 +13,18 @@ , quantize ) where -import Prelude hiding (id, log) +import Prelude hiding (log) import Control.Applicative ((<$>), (<|>)) import Control.Lens ((%=), (.=), use) import Control.Monad (forM_, when) +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 import GHC.RTS.Events.Analyze.Utils -import GHC.RTS.Events.Analyze.StrictState (State, execState) +import GHC.RTS.Events.Analyze.StrictState (State, execState, put, modify, get, runState) import GHC.RTS.Events.Analyze.Types import GHC.RTS.Events.Analyze.Script @@ -43,49 +44,86 @@ the analysis combines such events. -------------------------------------------------------------------------------} -analyze :: Options -> EventLog -> EventAnalysis -analyze Options{..} log = - let analysis = execState (mapM_ analyzeEvent (sortedEvents log)) - initialEventAnalysis - in analysis { eventTotals = computeTotals (_events analysis) } +analyze :: Options -> EventLog -> [EventAnalysis] +analyze opts@Options{..} log = + let analyses = execState (mapM_ analyzeEvent (sortedEvents log)) + [initialEventAnalysis opts] + in reverse + [ analysis { eventTotals = computeTotals (_events analysis) + , eventStarts = computeStarts (_events analysis) } + | analysis <- (if length analyses > 1 then drop 1 else id) analyses ] where - analyzeEvent :: Event -> State EventAnalysis () - analyzeEvent (Event time spec) = case spec of + isWindowEvent :: EventId -> Bool + isWindowEvent = case optionsWindowEvent of + [] -> const False + nm -> (== parseGroupId nm) + + analyzeEvent :: Event -> State [EventAnalysis] () + analyzeEvent (Event time spec) = do + cur $ recordShutdown time + case spec of -- CapCreate/CapDelete are the "new" events (ghc >= 7.6) -- Startup/Shutdown are older (to support older eventlogs) - CapCreate _cap -> recordStartup time - CapDelete _cap -> recordShutdown time - Startup _numCaps -> recordStartup time - Shutdown -> recordShutdown time + CapCreate _cap -> cur $ recordStartup time + CapDelete _cap -> cur $ recordShutdown time + Startup _numCaps -> cur $ recordStartup time + Shutdown -> cur $ recordShutdown time -- Thread info - CreateThread tid -> recordThreadCreation tid time - (finishThread -> Just tid) -> recordThreadFinish tid time + CreateThread tid -> cur $ recordThreadCreation tid time + (finishThread -> Just tid) -> cur $ recordThreadFinish tid time -- Start/end events - ThreadLabel tid l -> labelThread tid l - (startId -> Just eid) -> recordEventStart eid time - (stopId -> Just eid) -> recordEventStop eid time + 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 :) + 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 $ EventUser e + startId (UserMessage (prefix optionsUserStart -> Just e)) = Just $ parseGroupId e startId _ = Nothing stopId :: EventInfo -> Maybe EventId stopId (StopThread tid _) = Just $ EventThread tid stopId EndGC = Just $ EventGC - stopId (UserMessage (prefix optionsUserStop -> Just e)) = Just $ EventUser e + stopId (UserMessage (prefix optionsUserStop -> Just e)) = Just $ parseGroupId e stopId _ = Nothing + 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 m = do + h:t <- get + case runState m h of + (r,h') -> put (h':t) >> return r + -- We take the _first_ CapCreate to be the official startup time recordStartup :: Timestamp -> State EventAnalysis () recordStartup time = startup %= (<|> Just time) --- We take the _last_ CapDelete to be the official shutdown tiem +-- We take the last time of any event to be the official shutdown time recordShutdown :: Timestamp -> State EventAnalysis () -recordShutdown time = shutdown .= Just time +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 @@ -121,7 +159,7 @@ forM_ nowOpen $ \(eid, (start, _count)) -> case eid of EventGC -> return () EventThread _ -> return () - EventUser _ -> events %= (:) (eid, start, stop) + EventUser _ _ -> events %= (:) (eid, start, stop) simulateUserEventsStartAt :: Timestamp -> State EventAnalysis () simulateUserEventsStartAt newStart = openEvents %= Map.mapWithKey updUserEvent @@ -130,7 +168,7 @@ updUserEvent eid (oldStart, count) = case eid of EventGC -> (oldStart, count) EventThread _ -> (oldStart, count) - EventUser _ -> (newStart, count) + EventUser _ _ -> (newStart, count) recordThreadCreation :: ThreadId -> Timestamp -> State EventAnalysis () recordThreadCreation tid start = @@ -154,14 +192,16 @@ finishThread (StopThread tid ThreadFinished) = Just tid finishThread _ = Nothing -initialEventAnalysis :: EventAnalysis -initialEventAnalysis = EventAnalysis { +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) } computeTotals :: [(EventId, Timestamp, Timestamp)] -> Map EventId Timestamp @@ -174,17 +214,31 @@ go !acc ((eid, start, stop) : es) = go (Map.insertWith (+) eid (stop - start) acc) es +computeStarts :: [(EventId, Timestamp, Timestamp)] -> Map EventId Timestamp +computeStarts = go Map.empty + where + go :: Map EventId Timestamp + -> [(EventId, Timestamp, Timestamp)] + -> Map EventId Timestamp + go !acc [] = acc + go !acc ((eid, start, _) : es) = + go (Map.insertWith min eid start acc) es + {------------------------------------------------------------------------------- Using EventAnalysis -------------------------------------------------------------------------------} +-- | Lookup start time for a given event +eventStart :: EventAnalysis -> EventId -> Timestamp +eventStart EventAnalysis{..} eid = + case Map.lookup eid eventStarts of + Nothing -> error $ "eventStart: Invalid event ID " ++ show eid ++ ". " + ++ "Valid IDs are " ++ show (Map.keys eventStarts) + Just t -> t + -- | Lookup a total for a given event eventTotal :: EventAnalysis -> EventId -> Timestamp -eventTotal EventAnalysis{..} eid = - case Map.lookup eid eventTotals of - Nothing -> error $ "Invalid event ID " ++ show eid ++ ". " - ++ "Valid IDs are " ++ show (Map.keys eventTotals) - Just t -> t +eventTotal EventAnalysis{..} eid = fromMaybe 0 $ Map.lookup eid eventTotals -- | Compare event IDs compareEventIds :: EventAnalysis -> EventSort @@ -193,6 +247,7 @@ case sort of SortByName -> compare a b SortByTotal -> compare (eventTotal analysis b) (eventTotal analysis a) + SortByStart -> compare (eventStart analysis a) (eventStart analysis b) {------------------------------------------------------------------------------- Quantization 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 @@ -33,12 +33,17 @@ <*> switch ( long "totals" <> help "Generate totals report" ) - <*> option ( long "buckets" + <*> 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 100 + <> value 1000 ) <*> strOption ( long "start" <> metavar "STR" @@ -61,6 +66,9 @@ <> 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") )) diff --git a/src/GHC/RTS/Events/Analyze/Reports/Timed.hs b/src/GHC/RTS/Events/Analyze/Reports/Timed.hs --- a/src/GHC/RTS/Events/Analyze/Reports/Timed.hs +++ b/src/GHC/RTS/Events/Analyze/Reports/Timed.hs @@ -65,7 +65,7 @@ -- For threads we draw a background showing the thread's lifetime background :: EventId -> Maybe (Int, Int) background EventGC = Nothing - background (EventUser _) = Nothing + background (EventUser _ _) = Nothing background (EventThread tid) = case Map.lookup tid quantThreadInfo of Just (start, stop, _) -> Just (start, stop) @@ -74,8 +74,7 @@ quantTimesForEvent :: EventId -> Map Int Double quantTimesForEvent eid = case Map.lookup eid quantTimes of - Nothing -> error $ "Invalid event ID " ++ show eid ++ ". " - ++ "Valid IDs are " ++ show (Map.keys quantTimes) + Nothing -> Map.empty -- this event didn't happen in the window Just times -> times sorted :: Maybe EventSort -> [(EventId, a)] -> [(EventId, a)] 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 @@ -23,29 +23,36 @@ type D = Diagram B R2 renderReport :: Options -> Quantized -> Report -> (SizeSpec2D, D) -renderReport Options{optionsNumBuckets} +renderReport Options{optionsNumBuckets, optionsMilliseconds} Quantized{quantBucketSize} report = (D.sizeSpec2D rendered, rendered) where rendered :: D - rendered = D.vcat $ map renderSVGFragment (SVGTimeline : fragments) + rendered = D.vcat $ map (uncurry renderSVGFragment) + $ zip (cycle [D.white, D.ghostwhite]) + (SVGTimeline : fragments) fragments :: [SVGFragment] - fragments = map renderFragment report + fragments = map renderFragment $ zip report (cycle allColors) - renderSVGFragment :: SVGFragment -> D - renderSVGFragment (SVGSection title) = + renderSVGFragment :: Colour Double -> SVGFragment -> D + renderSVGFragment _ (SVGSection title) = padHeader (2 * blockSize) title - renderSVGFragment (SVGLine header blocks) = + 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 0)) - renderSVGFragment SVGTimeline = - padHeader blockSize mempty ||| timeline optionsNumBuckets quantBucketSize + (padHeader blockSize header ||| (blocks <> (block 0 # D.lw D.none))) + `D.atop` + (D.rect lineWidth blockHeight # D.alignL # D.fc bg # D.lw D.none) + renderSVGFragment _ SVGTimeline = + padHeader blockSize mempty + ||| timeline granularity optionsNumBuckets quantBucketSize + lineWidth = headerWidth + fromIntegral optionsNumBuckets * blockWidth + padHeader :: Double -> D -> D padHeader height h = D.translateX (0.5 * blockSize) h - <> D.rect headerWidth height # D.alignL # D.lw 0 + <> D.rect headerWidth height # D.alignL # D.lw D.none headerWidth :: Double headerWidth = blockSize -- extra padding @@ -55,35 +62,38 @@ 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 -> SVGFragment -renderFragment (ReportSection title) = SVGSection (renderText title (blockSize + 2)) -renderFragment (ReportLine line) = uncurry SVGLine $ renderLine line +renderFragment :: (ReportFragment, Colour Double) -> SVGFragment +renderFragment (ReportSection title,_) = SVGSection (renderText title (blockSize + 2)) +renderFragment (ReportLine line,c) = uncurry SVGLine $ renderLine c line -renderLine :: ReportLine -> (D, D) -renderLine line@ReportLineData{..} = +renderLine :: Colour Double -> ReportLine -> (D, D) +renderLine lc line@ReportLineData{..} = ( renderText lineHeader (blockSize + 2) - , blocks <> bgBlocks lineBackground + , blocks lc <> bgBlocks lineBackground ) where - blocks :: D - blocks = mconcat . map (mkBlock $ lineColor line) $ Map.toList lineValues + blocks :: Colour Double -> D + blocks c = mconcat . map (mkBlock $ lineColor c line) + $ Map.toList lineValues mkBlock :: Colour Double -> (Int, Double) -> D mkBlock c (b, q) = block b # D.fcA (c `D.withOpacity` qOpacity q) -lineColor :: ReportLine -> Colour Double -lineColor = eventColor . head . lineEventIds - -eventColor :: EventId -> Colour Double -eventColor EventGC = D.red -eventColor (EventUser _) = D.green -eventColor (EventThread _) = D.blue +lineColor :: Colour Double -> ReportLine -> Colour Double +lineColor c = eventColor c . head . lineEventIds +eventColor :: Colour Double -> EventId -> Colour Double +eventColor _ EventGC = D.red +eventColor c (EventUser _ _) = c +eventColor _ (EventThread _) = D.blue bgBlocks :: Maybe (Int, Int) -> D bgBlocks Nothing = mempty @@ -94,8 +104,9 @@ renderText :: String -> Double -> D renderText str size = - D.stroke (F.textSVG' (textOpts str size)) # D.fc D.black # D.lc D.black # D.alignL + D.stroke (F.textSVG' (textOpts str size)) # D.fc D.black # D.lc D.black # D.alignL # D.lw D.none + textOpts :: String -> Double -> TextOpts textOpts str size = TextOpts { @@ -120,25 +131,37 @@ -- visually see anyway. qOpacity :: Double -> Double qOpacity 0 = 0 -qOpacity q = 0.1 + q * 0.9 +qOpacity q = 0.3 + q * 0.7 block :: Int -> D -block i = D.translateX (blockSize * fromIntegral i) - $ D.rect blockSize blockSize +block i = D.translateX (blockWidth * fromIntegral i) + $ D.rect blockWidth blockHeight # D.lw D.none blockSize :: Double -blockSize = 10 +blockSize = blockHeight -timeline :: Int -> Timestamp -> D -timeline numBuckets bucketSize = - mconcat [ timelineBlock b # D.translateX (fromIntegral b * blockSize) +blockWidth :: Double +blockWidth = 2 + +blockHeight :: Double +blockHeight = 14 + +data TimelineGranularity = TimelineSeconds | TimelineMilliseconds + +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 ] where + blockMod = 10 `div` (round blockWidth) timelineBlock b - | b `rem`5 == 0 = D.strokeLine bigLine # D.lw 0.5 - <> (renderText (bucketTime b) 9 # D.translateY 8) - | otherwise = D.strokeLine smallLine # D.lw 0.5 # D.translateY 1 + | b `rem` (5 * blockMod) == 0 + = D.strokeLine bigLine # D.lw (D.Local 0.5) + <> (renderText (bucketTime b) blockHeight # D.translateY (blockHeight - 2)) + | otherwise + = D.strokeLine smallLine # D.lw (D.Local 0.5) # D.translateY 1 bucketTime :: Int -> String bucketTime b = let timeNs :: Timestamp @@ -146,8 +169,32 @@ timeS :: Double timeS = fromIntegral timeNs / 1000000000 - in printf "%0.1fs" timeS - bigLine = mkLine [(0, 4), (blockSize, 0)] - smallLine = mkLine [(0, 3), (blockSize, 0)] + timeMS :: Double + timeMS = fromIntegral timeNs / 1000000 + + in case granularity of + TimelineMilliseconds -> printf "%0.1fms" timeMS + TimelineSeconds -> printf "%0.1fs" timeS + + bigLine = mkLine [(0, 4), (10, 0)] + smallLine = mkLine [(0, 3), (10, 0)] mkLine = D.fromSegments . map (D.straight . D.r2) + +-- copied straight out of export list for Data.Colour.Names +allColors :: (Ord a, Floating a) => [Colour a] +allColors = + [D.blueviolet + ,D.brown + ,D.cadetblue + ,D.coral + ,D.cornflowerblue + ,D.crimson + ,D.cyan + ,D.darkcyan + ,D.darkgoldenrod + ,D.darkgreen + ,D.darkorange + ,D.goldenrod + ,D.green + ] 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 @@ -16,7 +16,7 @@ , scriptQQ ) where -import Control.Applicative ((<$>), (<*>), (*>), (<*)) +import Control.Applicative ((<$>), (<*>), (*>), (<*), pure) import Data.List (intercalate) import Data.Word (Word32) import Language.Haskell.TH.Lift (deriveLiftMany) @@ -80,6 +80,11 @@ -- Example -- > user by name | SortByTotal + -- | Sort by start time + -- + -- Example + -- > user by start + | SortByStart deriving Show -- | Commands @@ -153,7 +158,7 @@ type Parser a = Parsec String () a pEventId :: Parser EventId -pEventId = (EventUser <$> stringLiteral "user event") +pEventId = (EventUser <$> stringLiteral <*> pure 0 "user event") <|> (EventThread <$> pThreadId "thread event") <|> (const EventGC <$> reserved "GC") where @@ -175,6 +180,7 @@ pEventSort = optionMaybe $ reserved "by" *> ( (const SortByTotal <$> reserved "total") <|> (const SortByName <$> reserved "name") + <|> (const SortByStart <$> reserved "start") ) pTitle :: Parser (Maybe Title) @@ -221,7 +227,7 @@ unparseEventId :: EventId -> String unparseEventId EventGC = "GC" -unparseEventId (EventUser e) = e +unparseEventId (EventUser e _) = e unparseEventId (EventThread tid) = show tid unparseTitle :: Maybe Title -> String @@ -232,6 +238,7 @@ 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 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 @@ -11,6 +11,7 @@ , runState , evalState , execState + , modify -- * Re-exports , module Control.Monad.State.Strict ) where @@ -55,3 +56,6 @@ execState :: State s a -> s -> s execState act = runIdentity . execStateT act + +modify :: (s -> s) -> State s () +modify = StateT . St.modify' 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 @@ -9,7 +9,9 @@ , startup , shutdown , numThreads + , inWindow , Quantized(..) + , GroupId , showEventId , isUserEvent , isThreadEvent @@ -35,22 +37,26 @@ -- > traceEventIO "START