packages feed

ghc-events-analyze 0.2.0 → 0.2.1

raw patch · 9 files changed

+257/−115 lines, 9 filesdep ~diagrams-libdep ~diagrams-svgdep ~lens

Dependency ranges changed: diagrams-lib, diagrams-svg, lens, mtl, optparse-applicative, transformers

Files

ghc-events-analyze.cabal view
@@ -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+                     <http://www.well-typed.com/blog/2014/02/ghc-events-analyze/ Performance profiling with ghc-events-analyze>+                     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
src/GHC/RTS/Events/Analyze.hs view
@@ -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)
src/GHC/RTS/Events/Analyze/Analysis.hs view
@@ -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
src/GHC/RTS/Events/Analyze/Options.hs view
@@ -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")   ))
src/GHC/RTS/Events/Analyze/Reports/Timed.hs view
@@ -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)]
src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs view
@@ -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+  ]
src/GHC/RTS/Events/Analyze/Script.hs view
@@ -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
src/GHC/RTS/Events/Analyze/StrictState.hs view
@@ -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'
src/GHC/RTS/Events/Analyze/Types.hs view
@@ -9,7 +9,9 @@   , startup   , shutdown   , numThreads+  , inWindow   , Quantized(..)+  , GroupId   , showEventId   , isUserEvent   , isThreadEvent@@ -35,22 +37,26 @@     -- > traceEventIO "START <label>"     -- > ...     -- > traceEventIO "STOP <label>"-  | EventUser String+  | EventUser String GroupId      -- | Threads   | EventThread ThreadId   deriving (Eq, Ord, Show) +type GroupId = Int+ -- | Command line options data Options = Options {     optionsGenerateTimedSVG   :: Bool   , optionsGenerateTimedText  :: Bool   , optionsGenerateTotalsText :: Bool+  , optionsWindowEvent        :: String   , optionsNumBuckets         :: Int   , optionsUserStart          :: String   , optionsUserStop           :: String   , optionsScriptTotals       :: FilePath  -- "" denotes the standard script   , optionsScriptTimed        :: FilePath+  , optionsMilliseconds       :: Bool     -- Defined last to make defining the parser easier   , optionsInput              :: FilePath   }@@ -94,12 +100,14 @@      -- | Total amount of time per event (non-strict)   , eventTotals :: Map EventId Timestamp+  , eventStarts :: Map EventId Timestamp      -- | Timestamp of the Startup event   , _startup :: !(Maybe Timestamp)      -- | Timestamp of the Shutdown event   , _shutdown :: !(Maybe Timestamp)+  , _inWindow :: Bool   }   deriving Show @@ -135,13 +143,13 @@ -- `quantThreadInfo` from `Quantized`). showEventId :: Map ThreadId (a, a, String) -> EventId -> String showEventId _     EventGC          = "GC"-showEventId _    (EventUser event) = event+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 (EventUser{}) = True isUserEvent _             = False  isThreadEvent :: EventId -> Bool