ghc-events-analyze 0.2.4 → 0.2.5
raw patch · 12 files changed
+303/−182 lines, 12 filesdep +blaze-svgdep +bytestringdep +hashabledep ~SVGFontsdep ~basedep ~containers
Dependencies added: blaze-svg, bytestring, hashable, regex-base, regex-pcre-builtin, unordered-containers
Dependency ranges changed: SVGFonts, base, containers, ghc-events, lens, optparse-applicative
Files
- ChangeLog +6/−0
- ghc-events-analyze.cabal +16/−10
- src/GHC/RTS/Events/Analyze.hs +1/−1
- src/GHC/RTS/Events/Analyze/Analysis.hs +37/−36
- src/GHC/RTS/Events/Analyze/Options.hs +5/−3
- src/GHC/RTS/Events/Analyze/Reports/Timed.hs +21/−15
- src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs +83/−46
- src/GHC/RTS/Events/Analyze/Reports/Totals.hs +11/−8
- src/GHC/RTS/Events/Analyze/Script.hs +60/−24
- src/GHC/RTS/Events/Analyze/Script/Standard.hs +2/−2
- src/GHC/RTS/Events/Analyze/Types.hs +55/−32
- src/GHC/RTS/Events/Analyze/Utils.hs +6/−5
ChangeLog view
@@ -1,3 +1,9 @@+0.2.5++ * Add suppor for filtering threads by name, and improve+ performance of relabelling.+ (2017-03-11 Pepe Iborra <mnislaih@gmail.com>)+ 0.2.4 * Fix bug in timeline rendering when using --tick-every
ghc-events-analyze.cabal view
@@ -1,5 +1,5 @@ name: ghc-events-analyze-version: 0.2.4+version: 0.2.5 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,19 +51,25 @@ GHC.RTS.Events.Analyze.Reports.Timed GHC.RTS.Events.Analyze.Reports.Timed.SVG - build-depends: base >= 4.5 && < 4.10,- ghc-events >= 0.4 && < 0.5,- optparse-applicative >= 0.11 && < 0.14,- diagrams-lib >= 1.3 && < 1.4,+ build-depends: base >= 4.8 && < 4.12,+ blaze-svg >= 0.3 && < 0.4,+ bytestring >= 0.10 && < 0.11,+ containers >= 0.5 && < 0.7,+ diagrams-lib >= 1.3 && < 1.5, diagrams-svg >= 1.1 && < 1.5,- SVGFonts >= 1.5 && < 1.7,- containers >= 0.5 && < 0.6,- lens >= 3.10 && < 4.15,- mtl >= 2.2.1 && < 2.3,- transformers >= 0.3 && < 0.6, filepath >= 1.3 && < 1.5,+ ghc-events >= 0.6,+ hashable >= 1.2 && < 1.3,+ lens >= 3.10 && < 4.18,+ mtl >= 2.2.1 && < 2.3,+ optparse-applicative >= 0.11 && < 0.15, parsec >= 3.1 && < 3.2,+ regex-base >= 0.93 && < 0.94,+ regex-pcre-builtin >= 0.94 && < 0.95,+ SVGFonts >= 1.5 && < 1.8, th-lift >= 0.6 && < 0.8,+ transformers >= 0.3 && < 0.6,+ unordered-containers >= 0.2 && < 0.3, -- No version: whatever is bundled with ghc template-haskell
src/GHC/RTS/Events/Analyze.hs view
@@ -65,7 +65,7 @@ (prefixAnalysisNumber i "timed.txt") (Timed.writeReport timed) -getScript :: FilePath -> Script -> IO (String, Script)+getScript :: FilePath -> Script String -> IO (String, Script String) getScript "" def = return ("default script", def) getScript path _ = do mScript <- parseFromFile pScript path
src/GHC/RTS/Events/Analyze/Analysis.hs view
@@ -14,12 +14,14 @@ import Prelude hiding (log) import Control.Applicative ((<|>))-import Control.Lens ((%=), (.=), at, use)+import Control.Lens import Control.Monad (forM_, when, void) import Data.Maybe (fromMaybe, isNothing)-import Data.Map.Strict (Map)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap import GHC.RTS.Events hiding (events)-import qualified Data.Map.Strict as Map #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))@@ -35,7 +37,7 @@ -------------------------------------------------------------------------------} sortedEvents :: EventLog -> [Event]-sortedEvents (EventLog _header (Data es)) = map ce_event (sortEvents es)+sortedEvents (EventLog _header (Data es)) = sortEvents es readEventLog :: FilePath -> IO EventLog readEventLog = throwLeftStr . readEventLogFromFile@@ -61,7 +63,7 @@ Just ev -> (== ev) analyzeEvent :: Event -> State AnalysisState ()- analyzeEvent (Event time spec) = do+ analyzeEvent (Event time spec _mb_cap) = do cur $ recordShutdown time case spec of -- CapCreate/CapDelete are the "new" events (ghc >= 7.6)@@ -116,36 +118,36 @@ recordEventStart :: EventId -> Timestamp -> State EventAnalysis () recordEventStart eid start = do- (oldValue, newOpen) <- Map.insertLookupWithKey push eid (start, 1) <$> use openEvents- openEvents .= newOpen+ oldValue <- openEvents . at eid <<%= Just . push (start,1) case (eid, oldValue) of -- Pretend user events stop on the _first_ StartGC (EventGC, Nothing) -> simulateUserEventsStopAt start _ -> return () where- push _ (_newStart, _newCount) (oldStart, oldCount) =+ push _new Nothing = _new+ push (_newStart, _newCount) (Just (oldStart, oldCount)) = -- _newCount will always be 1; _newStart is irrelevant let count' = oldCount + 1 in count' `seq` (oldStart, count') recordEventStop :: EventId -> Timestamp -> State EventAnalysis () recordEventStop eid stop = do- (newValue, newOpen) <- Map.updateLookupWithKey pop eid <$> use openEvents- case newValue of- Just (start, 0) -> do- openEvents %= Map.delete eid+ oldValue <- openEvents . at eid <<%= (>>= pop)+ case oldValue of+ Just (start, 1) -> do events %= (:) (eid, start, stop) when (eid == EventGC) $ simulateUserEventsStartAt stop _ ->- openEvents .= newOpen+ return () where- pop _ (start, count) =+ pop (_start, 1) = Nothing+ pop (start, count) = let count' = count - 1 in count' `seq` Just (start, count') simulateUserEventsStopAt :: Timestamp -> State EventAnalysis () simulateUserEventsStopAt stop = do- nowOpen <- Map.toList <$> use openEvents+ nowOpen <- itoList <$> use openEvents forM_ nowOpen $ \(eid, (start, _count)) -> case eid of EventGC -> return () EventThread _ -> return ()@@ -181,11 +183,11 @@ recordThreadCreation :: ThreadId -> Timestamp -> State AnalysisState () recordThreadCreation tid start = do let label = show tid- cur $ ifInWindow $ recordWindowThreadCreation tid start label- runningThreads . at tid .= Just label+ cur $ ifInWindow $ recordWindowThreadCreation tid start [label]+ runningThreads . at tid .= Just [label] -- Record thread creation in current window-recordWindowThreadCreation :: ThreadId -> Timestamp -> String -> State EventAnalysis ()+recordWindowThreadCreation :: ThreadId -> Timestamp -> [String] -> State EventAnalysis () recordWindowThreadCreation tid start label = windowThreadInfo . at tid .= Just (start, start, label) @@ -217,12 +219,11 @@ mapM_ (\tid -> cur $ recordWindowThreadFinish tid stop) $ threadIds threads labelThread :: ThreadId -> String -> State AnalysisState ()-labelThread tid l = do- runningThreads . at tid %= fmap updLabel+labelThread tid !l = do+ runningThreads . at tid %= fmap (l :) cur $ windowThreadInfo . at tid %= fmap updThreadInfo where- updThreadInfo (start, stop, l') = (start, stop, updLabel l')- updLabel l' = l ++ " (" ++ l' ++ ")"+ updThreadInfo (start, stop, !ls) = (start, stop, l : ls) finishThread :: EventInfo -> Maybe ThreadId finishThread (StopThread tid ThreadFinished) = Just tid@@ -246,22 +247,22 @@ , _inWindow = isNothing (optionsWindowEvent opts) } -computeTotals :: [(EventId, Timestamp, Timestamp)] -> Map EventId Timestamp-computeTotals = go Map.empty+computeTotals :: [(EventId, Timestamp, Timestamp)] -> HashMap EventId Timestamp+computeTotals = go mempty where- go :: Map EventId Timestamp+ go :: HashMap EventId Timestamp -> [(EventId, Timestamp, Timestamp)]- -> Map EventId Timestamp+ -> HashMap EventId Timestamp go !acc [] = acc go !acc ((eid, start, stop) : es) = go (Map.insertWith (+) eid (stop - start) acc) es -computeStarts :: [(EventId, Timestamp, Timestamp)] -> Map EventId Timestamp+computeStarts :: [(EventId, Timestamp, Timestamp)] -> HashMap EventId Timestamp computeStarts = go Map.empty where- go :: Map EventId Timestamp+ go :: HashMap EventId Timestamp -> [(EventId, Timestamp, Timestamp)]- -> Map EventId Timestamp+ -> HashMap EventId Timestamp go !acc [] = acc go !acc ((eid, start, _) : es) = go (Map.insertWith min eid start acc) es@@ -302,24 +303,24 @@ , quantBucketSize = bucketSize } where- go :: Map EventId (Map Int Double)+ go :: HashMap EventId (IntMap Double) -> [(EventId, Timestamp, Timestamp)]- -> Map EventId (Map Int Double)+ -> HashMap EventId (IntMap Double) go !acc [] = acc go !acc ((eid, start, end) : ttimes') = let startBucket, endBucket :: Int startBucket = bucket start endBucket = bucket end - updates :: Map Int Double- updates = Map.fromAscList+ updates :: IntMap Double+ updates = IntMap.fromAscList $ [ (b, delta startBucket endBucket start end b) | b <- [startBucket .. endBucket] ] - update :: Maybe (Map Int Double) -> Maybe (Map Int Double)+ update :: Maybe (IntMap Double) -> Maybe (IntMap Double) update Nothing = Just $ updates- update (Just old) = let new = Map.unionWith (+) updates old+ update (Just old) = let new = IntMap.unionWith (+) updates old in new `seq` Just new in go (Map.alter update eid acc) ttimes'@@ -357,5 +358,5 @@ t2d :: Timestamp -> Double t2d = fromInteger . toInteger - quantizeThreadInfo :: (Timestamp, Timestamp, String) -> (Int, Int, String)+ quantizeThreadInfo :: (Timestamp, Timestamp, a) -> (Int, Int, a) quantizeThreadInfo (start, stop, label) = (bucket start, bucket stop, label)
src/GHC/RTS/Events/Analyze/Options.hs view
@@ -138,9 +138,11 @@ , " | INT -- thread event" , " | \"GC\" -- garbage collection" , ""- , "<filter> ::= <eventId> -- single event"- , " | \"user\" -- any user event"- , " | \"thread\" -- any thread event"+ , "<filter> ::= <eventId> -- single event"+ , " | \"user \" -- any user event"+ , " | \"thread\" -- any thread event"+ , " | \"thread REGEXP\" -- thread events for thread labels that match the regular expression"+ , " | \"thread -REGEXP\" -- thread events for thread labels that do not match the regular expression" , " | \"any\" \"[\" <filter> (\",\" <filter>)* \"]\"" , "" , "<sort> ::= \"total\""
src/GHC/RTS/Events/Analyze/Reports/Timed.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} module GHC.RTS.Events.Analyze.Reports.Timed ( Report , ReportFragment(..)@@ -6,12 +7,14 @@ , writeReport ) where +import Control.Lens (itoList, (^.), over, each, _3) import Data.Function (on)-import Data.List (sortBy, intercalate)-import Data.Map (Map)+import Data.List (group, sortBy, intercalate)+import Data.IntMap.Strict (IntMap) import System.IO (Handle, hPutStrLn, withFile, IOMode(WriteMode)) import Text.Printf (printf)-import qualified Data.Map as Map+import qualified Data.HashMap.Strict as Map+import qualified Data.IntMap.Strict as IntMap import GHC.RTS.Events.Analyze.Analysis import GHC.RTS.Events.Analyze.Script@@ -33,7 +36,7 @@ lineHeader :: String , lineEventIds :: [EventId] , lineBackground :: Maybe (Int, Int)- , lineValues :: Map Int Double+ , lineValues :: IntMap Double } deriving Show @@ -41,10 +44,10 @@ Report generation -------------------------------------------------------------------------------} -createReport :: EventAnalysis -> Quantized -> Script -> Report-createReport analysis Quantized{..} = concatMap go+createReport :: EventAnalysis -> Quantized -> Script String -> Report+createReport analysis Quantized{..} = concatMap go . fmap (fmap (mkThreadFilter (analysis^.windowThreadInfo))) where- go :: Command -> [ReportFragment]+ go :: Command (ThreadId -> Bool)-> [ReportFragment] go (Section title) = [ReportSection title] go (One eid title) =@@ -54,9 +57,12 @@ go (Sum f title) = [ReportLine $ sumLines title $ map (reportLine Nothing) (filtered f)] - reportLine :: Maybe Title -> (EventId, Map Int Double) -> ReportLine+ quantThreadInfoFlattened = over (each._3) flattenThreadLabels quantThreadInfo+ flattenThreadLabels = intercalate ":" . map head . group++ reportLine :: Maybe Title -> (EventId, IntMap Double) -> ReportLine reportLine title (eid, qs) = ReportLineData {- lineHeader = showTitle (showEventId quantThreadInfo eid) title+ lineHeader = showTitle (showEventId quantThreadInfoFlattened eid) title , lineEventIds = [eid] , lineBackground = background eid , lineValues = qs@@ -71,25 +77,25 @@ Just (start, stop, _) -> Just (start, stop) Nothing -> error $ "Invalid thread ID " ++ show tid - quantTimesForEvent :: EventId -> Map Int Double+ quantTimesForEvent :: EventId -> IntMap Double quantTimesForEvent eid = case Map.lookup eid quantTimes of- Nothing -> Map.empty -- this event didn't happen in the window+ Nothing -> mempty -- this event didn't happen in the window Just times -> times sorted :: Maybe EventSort -> [(EventId, a)] -> [(EventId, a)] sorted Nothing = id sorted (Just sort) = sortBy (compareEventIds analysis sort `on` fst) - filtered :: EventFilter -> [(EventId, Map Int Double)]- filtered f = filter (matchesFilter f . fst) (Map.toList quantTimes)+ filtered :: EventFilter (ThreadId -> Bool) -> [(EventId, IntMap Double)]+ filtered f = filter (matchesFilter f . fst) (itoList quantTimes) sumLines :: Maybe Title -> [ReportLine] -> ReportLine sumLines title qs = ReportLineData { lineHeader = showTitle "TOTAL" title , lineEventIds = concatMap lineEventIds qs , lineBackground = foldr1 combineBG $ map lineBackground qs- , lineValues = Map.unionsWith (+) $ map lineValues qs+ , lineValues = IntMap.unionsWith (+) $ map lineValues qs } where combineBG :: Maybe (Int, Int) -> Maybe (Int, Int) -> Maybe (Int, Int)@@ -123,7 +129,7 @@ reportLine :: ReportLine -> [String] reportLine ReportLineData{..} =- lineHeader : map showValue (unsparse 0 lineValues)+ lineHeader : unsparse "0.00" (over each showValue lineValues) showValue :: Double -> String showValue = printf "%0.2f"
src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs view
@@ -3,18 +3,19 @@ module GHC.RTS.Events.Analyze.Reports.Timed.SVG ( writeReport ) where--import Data.Maybe (catMaybes)+import Control.Lens (itoList)+import Data.List (foldl') import Data.Monoid ((<>)) import Diagrams.Backend.SVG (B, renderSVG) import Diagrams.Prelude (QDiagram, Colour, V2, N, Any, (#), (|||)) import GHC.RTS.Events (Timestamp) import Graphics.SVGFonts.Text (TextOpts(..)) import Text.Printf (printf)-import qualified Data.Map as Map import qualified Diagrams.Prelude as D import qualified Graphics.SVGFonts.Fonts as F import qualified Graphics.SVGFonts.Text as F+import qualified Graphics.SVGFonts.ReadFont as F+import qualified Diagrams.TwoD.Text as TT #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mempty, mconcat)@@ -24,16 +25,18 @@ import GHC.RTS.Events.Analyze.Reports.Timed hiding (writeReport) writeReport :: Options -> Quantized -> Report -> FilePath -> IO ()-writeReport options quantized report path =- uncurry (renderSVG path) $ renderReport options quantized report+writeReport options quantized report path = do+ font <- F.bit+ uncurry (renderSVG path) $ renderReport options quantized report font type D = QDiagram B V2 (N B) Any type SizeSpec = D.SizeSpec V2 Double -renderReport :: Options -> Quantized -> Report -> (SizeSpec, D)+renderReport :: Options -> Quantized -> Report -> F.PreparedFont Double -> (SizeSpec, D) renderReport options@Options{..} Quantized{quantBucketSize} report+ font = (sizeSpec, rendered) where sizeSpec = let w = Just $ D.width rendered@@ -44,21 +47,20 @@ rendered = D.vcat $ map (uncurry renderSVGFragment) $ zip (cycle [D.white, D.ghostwhite]) (SVGTimeline : fragments)- fragments :: [SVGFragment]- fragments = map (renderFragment options) $ zip report (cycle allColors)+ fragments = map (renderFragment options font) $ zip report (cycle allColors) renderSVGFragment :: Colour Double -> SVGFragment -> D renderSVGFragment _ (SVGSection 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 optionsBucketHeight header ||| (blocks <> (block options 0 # D.lw D.none)))+ (padHeader optionsBucketHeight (renderText header (optionsBucketHeight + 2)) ||| (blocks <> (block options 0 # D.lw D.none))) `D.atop` (D.rect lineWidth optionsBucketHeight # D.alignL # D.fc bg # D.lw D.none) renderSVGFragment _ SVGTimeline = padHeader optionsBucketHeight mempty- ||| timeline options optionsNumBuckets quantBucketSize+ ||| timeline options optionsNumBuckets quantBucketSize font lineWidth :: Double lineWidth = headerWidth + fromIntegral optionsNumBuckets * optionsBucketWidth@@ -68,35 +70,43 @@ D.translateX (0.5 * optionsBucketWidth) h <> D.rect headerWidth height # D.alignL # D.lw D.none + -- optimisation: find the longest text header, render+ -- it then check the rendered size and use that for+ -- width; it does not necessarily mean it's the right+ -- width to use but it's good enough considering speed+ -- trade-off headerWidth :: Double- headerWidth = optionsBucketWidth -- extra padding- + (maximum . catMaybes . map headerWidthOf $ fragments)+ headerWidth = optionsBucketWidth + widestHeader -- extra padding - headerWidthOf :: SVGFragment -> Maybe Double- headerWidthOf (SVGLine header _) = Just (D.width header)- headerWidthOf _ = Nothing+ widestHeader :: Double+ widestHeader =+ let headers = [ (header, length header) | SVGLine header _ <- fragments ]+ (maxHeader, _) = foldl' (\(s, l) (s', l') ->+ if l' > l then (s', l') else (s, l))+ ("", 0) headers+ in D.width $! mkSVGText maxHeader (optionsBucketHeight + 2) font data SVGFragment = SVGTimeline | SVGSection D- | SVGLine D D+ | SVGLine String D -renderFragment :: Options -> (ReportFragment, Colour Double) -> SVGFragment-renderFragment options@Options{..} = go+renderFragment :: Options -> F.PreparedFont Double -> (ReportFragment, Colour Double) -> SVGFragment+renderFragment options@Options{..} font = go where go :: (ReportFragment, Colour Double) -> SVGFragment- go (ReportSection title,_) = SVGSection (renderText title (optionsBucketHeight + 2))+ go (ReportSection title,_) = SVGSection (mkSVGText title (optionsBucketHeight + 2) font) go (ReportLine line,c) = uncurry SVGLine $ renderLine options c line -renderLine :: Options -> Colour Double -> ReportLine -> (D, D)+renderLine :: Options -> Colour Double -> ReportLine -> (String, D) renderLine options@Options{..} lc line@ReportLineData{..} =- ( renderText lineHeader (optionsBucketHeight + 2)+ ( lineHeader -- renderText lineHeader (optionsBucketHeight + 2) , blocks lc <> bgBlocks options lineBackground ) where blocks :: Colour Double -> D blocks c = mconcat . map (mkBlock $ lineColor c line)- $ Map.toList lineValues+ $ itoList lineValues mkBlock :: Colour Double -> (Int, Double) -> D mkBlock c (b, q) = block options b # D.fcA (c `D.withOpacity` qOpacity q)@@ -119,16 +129,20 @@ | 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+-- | Create a text diagram that is sized (as opposed to 'renderText').+-- The problem with this function is that it's *extremely* slow and+-- memory hungry in comparison to something simple like 'TT.text'.+-- This function should therefore be used as little as possible.+mkSVGText :: String -> Double -> F.PreparedFont Double -> D+mkSVGText str size font =+ D.stroke textSVG # D.fc D.black # D.lc D.black # D.alignL # D.lw D.none where- textSVG = F.textSVG' (textOpts size) str+ textSVG = F.textSVG' (textOpts size font) str -textOpts :: Double -> TextOpts Double-textOpts size =+textOpts :: Double -> F.PreparedFont Double -> TextOpts Double+textOpts size font = TextOpts {- textFont = F.lin+ textFont = font , mode = F.INSIDE_H , spacing = F.KERN , underline = False@@ -136,6 +150,13 @@ , textHeight = size } +-- | Render text with diagram's own engine. The issue with this text+-- is that it has no size: we can not tell how wide it is. For a+-- sized-text see 'mkSVGText'.+renderText :: String -> Double -> D+renderText str size =+ TT.fontSizeL (size / 2) $ TT.alignedText 0 0.5 str+ -- | Translate quantized value to opacity -- -- For every event and every bucket we record the percentage of that bucket@@ -158,29 +179,45 @@ borderWidth | optionsBorderWidth == 0 = D.none | otherwise = D.global optionsBorderWidth -timeline :: Options -> Int -> Timestamp -> D-timeline Options{..} numBuckets bucketSize =- mconcat [ timelineBlock tb # 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- ]+timeline :: Options -> Int -> Timestamp -> F.PreparedFont Double -> D+timeline Options{..} numBuckets bucketSize font =+ let timeBlocks = [ tb+ | 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 ]++ -- memoize the rendering of the last time label: if it's the same+ -- for the next 10 displays, why render it 10 times? Text is expensive.+ in case foldl' (\acc tb -> timelineBlock acc tb) mempty timeBlocks of+ (_, _, fullDiag) -> fullDiag+ where timelineBlockWidth :: Double timelineBlockWidth = fromIntegral optionsTickEvery * optionsBucketWidth + moveAlongTimeline :: Int -> D -> D+ moveAlongTimeline tb = D.translateX (fromIntegral tb * timelineBlockWidth)+ -- 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 (D.local 0.5) # D.translateY 1+ timelineBlock :: (String, D, D) -> Int -> (String, D, D)+ timelineBlock (lastStr, lastNumD, fullDiag) tb+ | tb `rem` 5 == 0 =+ let btime = bucketTime tb+ myNum = if lastStr == btime+ then lastNumD+ else mkSVGText btime optionsBucketHeight font # D.translateY (optionsBucketHeight - 2)+ myDiag = D.strokeLine bigLine # D.lw (D.local 0.5) <> myNum+ in (btime, myNum, fullDiag <> myDiag # moveAlongTimeline tb)+ | otherwise =+ let myDiag :: D+ myDiag = D.strokeLine smallLine+ # D.lw (D.local 0.5)+ # D.translateY 1+ # moveAlongTimeline tb+ in (lastStr, lastNumD, fullDiag <> myDiag) bucketTime :: Int -> String bucketTime tb = case optionsGranularity of
src/GHC/RTS/Events/Analyze/Reports/Totals.hs view
@@ -6,12 +6,12 @@ , writeReport ) where +import Control.Lens hiding (filtered) import Data.Function (on)-import Data.List (sortBy, intercalate)+import Data.List (sortBy, intercalate, group) import GHC.RTS.Events (Timestamp) import System.IO (Handle, hPutStrLn, withFile, IOMode(WriteMode)) import Text.Printf (printf)-import qualified Data.Map as Map import GHC.RTS.Events.Analyze.Analysis import GHC.RTS.Events.Analyze.Types@@ -40,10 +40,10 @@ Report generation -------------------------------------------------------------------------------} -createReport :: EventAnalysis -> Script -> Report-createReport analysis@EventAnalysis{..} = concatMap go+createReport :: EventAnalysis -> Script String -> Report+createReport analysis@EventAnalysis{..} = concatMap go . fmap (fmap (mkThreadFilter _windowThreadInfo)) where- go :: Command -> [ReportFragment]+ go :: Command (ThreadId -> Bool) -> [ReportFragment] go (Section title) = [ReportSection title] go (One eid title) =@@ -53,9 +53,12 @@ go (Sum f title) = [ReportLine $ sumLines title $ map (reportLine Nothing) (filtered f)] + flattenedThreadInfo = over (each._3) flattenThreadLabels _windowThreadInfo+ flattenThreadLabels = intercalate ":" . map head . group+ reportLine :: Maybe Title -> (EventId, Timestamp) -> ReportLine reportLine title (eid, total) = ReportLineData {- lineHeader = showTitle (showEventId _windowThreadInfo eid) title+ lineHeader = showTitle (showEventId flattenedThreadInfo eid) title , lineEventIds = [eid] , lineTotal = total }@@ -67,8 +70,8 @@ sorted Nothing = id sorted (Just sort) = sortBy (compareEventIds analysis sort `on` fst) - filtered :: EventFilter -> [(EventId, Timestamp)]- filtered f = filter (matchesFilter f . fst) (Map.toList eventTotals)+ filtered :: EventFilter (ThreadId -> Bool) -> [(EventId, Timestamp)]+ filtered f = filter (matchesFilter f . fst) (itoList eventTotals) sumLines :: Maybe Title -> [ReportLine] -> ReportLine sumLines title qs = ReportLineData {
src/GHC/RTS/Events/Analyze/Script.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -w -W #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-}@@ -17,11 +21,12 @@ , scriptQQ ) where +import Control.Applicative (optional) import Data.List (intercalate) import Language.Haskell.TH.Lift (deriveLiftMany) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax-import Text.Parsec+import Text.Parsec hiding (optional) import Text.Parsec.Language (haskellDef) import qualified Text.Parsec.Token as P @@ -40,13 +45,27 @@ -------------------------------------------------------------------------------} -- | A script is used to drive the construction of reports-type Script = [Command]+type Script a = [Command a] -- | Title of a section of an event type Title = String +-- | A positive (Include) or negative (Exclude) filter+data NameFilter a+ =+ -- | Negative filter+ -- Examples+ -- > "-finalizer.*"+ Exclude a+ -- | Positive filter+ -- Examples+ -- > "worker.*"+ | Include a+ | IncludeAll+ deriving (Show,Functor,Foldable,Traversable)+ -- | Event filters-data EventFilter =+data EventFilter a = -- | A single event -- -- Examples@@ -65,15 +84,17 @@ -- -- Example -- > thread- | IsThread+ -- > thread "!finalizer"+ | IsThread (NameFilter a) -- | Logical or -- -- Example -- > [GC, "foo", 5]- | Any [EventFilter]- deriving Show+ | Any [EventFilter a]+ deriving (Functor, Foldable, Traversable, Show) + -- | Sorting data EventSort = -- | Sort by event name@@ -95,7 +116,7 @@ deriving Show -- | Commands-data Command =+data Command a = -- | Start a new section -- -- Example@@ -113,24 +134,28 @@ -- Examples -- > user by total -- all user events, sorted -- > [4, 2, 3] -- thread events 4, 2 and 3, in that order- | All EventFilter (Maybe EventSort)+ | All (EventFilter a) (Maybe EventSort) -- | Sum over the specified events -- -- Example -- > sum user- | Sum EventFilter (Maybe Title)- deriving Show+ | Sum (EventFilter a) (Maybe Title)+ deriving (Functor, Foldable, Traversable, Show) + {------------------------------------------------------------------------------- Script execution -------------------------------------------------------------------------------} -matchesFilter :: EventFilter -> EventId -> Bool+matchesFilter :: EventFilter (ThreadId -> Bool) -> EventId -> Bool matchesFilter (Is eid') eid = eid' == eid-matchesFilter IsUser eid = isUserEvent eid-matchesFilter IsThread eid = isThreadEvent eid-matchesFilter (Any fs) eid = or (map (`matchesFilter` eid) fs)+matchesFilter IsUser eid = isUserEvent eid+matchesFilter (IsThread IncludeAll) (isThreadEvent -> Just _) = True+matchesFilter (IsThread (Include r)) (isThreadEvent -> Just tid) = r tid+matchesFilter (IsThread (Exclude r)) (isThreadEvent -> Just tid) = not(r tid)+matchesFilter IsThread{} _ = False+matchesFilter (Any fs) eid = any (`matchesFilter` eid) fs {------------------------------------------------------------------------------- Lexical analysis@@ -169,10 +194,10 @@ type Parser a = Parsec String () a -pScript :: Parser Script+pScript :: Parser (Script String) pScript = whiteSpace *> many1 pCommand <* eof -pCommand :: Parser Command+pCommand :: Parser (Command String) pCommand = (Section <$> (reserved "section" *> stringLiteral)) <|> (One <$> pEventId <*> pTitle) <|> (Sum <$> (reserved "sum" *> pEventFilter) <*> pTitle)@@ -185,10 +210,10 @@ where pThreadId = fromIntegral <$> natural -pEventFilter :: Parser EventFilter+pEventFilter :: Parser (EventFilter String) pEventFilter = (Is <$> pEventId) <|> (const IsUser <$> reserved "user")- <|> (const IsThread <$> reserved "thread")+ <|> (IsThread <$> (reserved "thread" *> pNameFilter)) <|> (Any <$> (squares $ commaSep1 pEventFilter)) pEventSort :: Parser (Maybe EventSort)@@ -201,14 +226,20 @@ pTitle :: Parser (Maybe Title) pTitle = optionMaybe (reserved "as" *> stringLiteral) +pNameFilter :: Parser (NameFilter String)+pNameFilter = f <$> optional stringLiteral where+ f Nothing = IncludeAll+ f (Just ('-' : nameRegexp)) = Exclude nameRegexp+ f (Just nameRegexp) = Include nameRegexp+ {------------------------------------------------------------------------------- Unparsing -------------------------------------------------------------------------------} -unparseScript :: Script -> [String]+unparseScript :: Script String -> [String] unparseScript = concatMap unparseCommand -unparseCommand :: Command -> [String]+unparseCommand :: Command String -> [String] unparseCommand (Section title) = ["", "section " ++ show title] unparseCommand (One eid title) = [unparseEventId eid ++ " " ++ unparseTitle title] unparseCommand (Sum f title) = ["sum " ++ unparseFilter f ++ " " ++ unparseTitle title]@@ -219,12 +250,17 @@ unparseEventId (EventUser e _) = show e unparseEventId (EventThread tid) = show tid -unparseFilter :: EventFilter -> String+unparseFilter :: EventFilter String -> String unparseFilter (Is eid) = unparseEventId eid unparseFilter IsUser = "user"-unparseFilter IsThread = "thread"+unparseFilter (IsThread nameFilter) = "thread" ++ unparseNameFilter nameFilter unparseFilter (Any fs) = "[" ++ intercalate "," (map unparseFilter fs) ++ "]" +unparseNameFilter :: NameFilter String -> String+unparseNameFilter (IncludeAll) = ""+unparseNameFilter (Include s) = ' ' : s+unparseNameFilter (Exclude s) = ' ' : '-' : s+ unparseSort :: Maybe EventSort -> String unparseSort Nothing = "" unparseSort (Just SortByName) = "by name"@@ -239,7 +275,7 @@ Quasi-quoting -------------------------------------------------------------------------------} -$(deriveLiftMany [''EventId, ''EventFilter, ''EventSort, ''Command])+$(deriveLiftMany [''EventId, ''EventFilter, ''NameFilter, ''EventSort, ''Command]) #if !MIN_VERSION_template_haskell(2,10,0) instance Lift Word32 where@@ -254,7 +290,7 @@ , quoteDec = \_ -> fail "Cannot use script as a declaration" } -parseScriptString :: Monad m => String -> String -> m Script+parseScriptString :: Monad m => String -> String -> m (Script String) parseScriptString source input = case runParser pScript () source input of Left err -> fail (show err)
src/GHC/RTS/Events/Analyze/Script/Standard.hs view
@@ -6,7 +6,7 @@ import GHC.RTS.Events.Analyze.Script -defaultScriptTotals :: Script+defaultScriptTotals :: Script String defaultScriptTotals = [scriptQQ| GC @@ -19,7 +19,7 @@ sum thread |] -defaultScriptTimed :: Script+defaultScriptTimed :: Script String defaultScriptTimed = [scriptQQ| GC
src/GHC/RTS/Events/Analyze/Types.hs view
@@ -1,8 +1,12 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} module GHC.RTS.Events.Analyze.Types ( -- * Events EventId(..)- , SortIndex+ , EventLabel+ , EventSubscript , isUserEvent , isThreadEvent , parseUserEvent@@ -12,10 +16,12 @@ , Options(..) -- * Analysis state , RunningThreads+ , ThreadLabels , threadIds , ThreadInfo , EventAnalysis(..) , AnalysisState(..)+ , mkThreadFilter -- ** EventAnalysis lenses , events , windowThreadInfo@@ -28,13 +34,17 @@ , windowAnalyses -- * Analysis result , Quantized(..)+ , ThreadId ) where -import Control.Lens (makeLenses)+import Control.Lens import Data.Char-import Data.Map (Map)+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import Data.IntMap.Strict (IntMap)+import GHC.Generics import GHC.RTS.Events (Timestamp, ThreadId)-import qualified Data.Map as Map+import Text.Regex.PCRE {------------------------------------------------------------------------------- Event identifiers@@ -52,37 +62,40 @@ -- -- To use user events, do --- -- > traceEventIO "START <label>"+ -- > traceEventIO "START <subscript> <label>" -- > ...- -- > traceEventIO "STOP <label>"- | EventUser String SortIndex+ -- > traceEventIO "STOP <subscript> <label>"+ --+ -- If the <subscript> is omitted it is assumed to be 0+ -- (see 'EventSubscript' for details).+ | EventUser EventLabel EventSubscript -- | Threads | EventThread ThreadId- deriving (Eq, Ord, Show)+ deriving (Eq, Generic, Hashable, Ord, Show) --- | Sort index+-- | The user-readable name for an event+type EventLabel = String++-- | Event subscript ----- 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+-- The combination of the 'EventLabel' and the 'EventSubscript' uniquely+-- identifies an event; however, only the 'EventLabel' is shown in the report. ----- > traceEventIO "START <sortIndex> <label>"--- > ...--- > traceEventIO "STOP <sortIndex> <label>"-type SortIndex = Int+-- When it is not required, the subscript can simply be set to 0.+type EventSubscript = Int isUserEvent :: EventId -> Bool isUserEvent (EventUser{}) = True isUserEvent _ = False -isThreadEvent :: EventId -> Bool-isThreadEvent (EventThread _) = True-isThreadEvent _ = False+isThreadEvent :: EventId -> Maybe ThreadId+isThreadEvent (EventThread tid) = Just tid+isThreadEvent _ = Nothing -- | Parse user event ----- If the event name starts with a digit, regard it as a 'SortIndex'.+-- If the event name starts with a digit, regard it as a 'EventSubscript'. parseUserEvent :: String -> EventId parseUserEvent s = case span isDigit s of@@ -93,10 +106,10 @@ -- -- The argument is typically either `__threadInfo` from `EventAnalysis` or -- `quantThreadInfo` from `Quantized`.-showEventId :: Map ThreadId (a, a, String) -> EventId -> String+showEventId :: HashMap ThreadId (a,b,String) -> EventId -> String showEventId _ EventGC = "GC" showEventId _ (EventUser event _) = event-showEventId info (EventThread tid) = case Map.lookup tid info of+showEventId info (EventThread tid) = case info ^. at tid of Just (_, _, l) -> l Nothing -> show tid @@ -132,19 +145,23 @@ Analysis state -------------------------------------------------------------------------------} +-- Thread labels held by a thread (as indicated by ThreadLabel events)+-- in inverse chronological order (most recent first)+type ThreadLabels = [String]+ -- | Map of currently running threads to their labels-type RunningThreads = Map ThreadId String+type RunningThreads = HashMap ThreadId ThreadLabels threadIds :: RunningThreads -> [ThreadId]-threadIds = Map.keys+threadIds = map fst . itoList -- | 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)+-- When was the thread created, when was it destroyed, and what are the+-- thread labels in inverse cronological order (as indicated by ThreadLabel events) -- -- The default label for each thread is the thread ID-type ThreadInfo = Map ThreadId (Timestamp, Timestamp, String)+type ThreadInfo = HashMap ThreadId (Timestamp, Timestamp, ThreadLabels) -- | 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@@ -176,11 +193,11 @@ -- separately for separate HECs). We therefore record for each open event -- how many start events we have seen, and hence how many ends we need to -- see before counting the event as finished.- , _openEvents :: !(Map EventId (Timestamp, Int))+ , _openEvents :: !(HashMap EventId (Timestamp, Int)) -- | Total amount of time per event (non-strict)- , eventTotals :: Map EventId Timestamp- , eventStarts :: Map EventId Timestamp+ , eventTotals :: HashMap EventId Timestamp+ , eventStarts :: HashMap EventId Timestamp -- | Timestamp of the Startup event , _startup :: !(Maybe Timestamp)@@ -193,6 +210,12 @@ $(makeLenses ''EventAnalysis) +mkThreadFilter :: ThreadInfo-> String -> ThreadId -> Bool+mkThreadFilter analysis regex =+ let r :: Regex = makeRegex regex+ m = analysis & each %~ (\(_,_,tn) -> any (matchTest r) tn)+ in \tid -> m ^?! ix tid+ -- | State while running an analysis. Keeps track of currently running threads, -- and appends an 'EventAnalysis' per window. data AnalysisState = AnalysisState {@@ -217,9 +240,9 @@ -- number of cores. data Quantized = Quantized { -- | For each event and each bucket how much of that bucket the event used up- quantTimes :: Map EventId (Map Int Double)+ quantTimes :: HashMap EventId (IntMap Double) -- | Like threadInfo, but quantized (start and finish bucket)- , quantThreadInfo :: Map ThreadId (Int, Int, String)+ , quantThreadInfo :: HashMap ThreadId (Int, Int, ThreadLabels) -- | Size of each bucket , quantBucketSize :: Timestamp }
src/GHC/RTS/Events/Analyze/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} module GHC.RTS.Events.Analyze.Utils ( throwLeft , throwLeftStr@@ -10,11 +11,10 @@ , renderTable ) where +import Control.Lens import Control.Exception import Data.List (transpose) import Data.Either (partitionEithers)-import Data.Map (Map)-import qualified Data.Map as Map throwLeft :: Exception e => IO (Either e a) -> IO a throwLeft act = act >>= \ea -> case ea of Left e -> throwIO e@@ -72,10 +72,11 @@ -- | Turn a sparse representation of a list into a regular list, using -- a default value for the blanks-unsparse :: forall a. a -> Map Int a -> [a]-unsparse blank = go 0 . Map.toList+{-# INLINE unsparse #-}+unsparse :: FoldableWithIndex Int f => t -> f t -> [t]+unsparse blank = go 0 . itoList where- go :: Int -> [(Int, a)] -> [a]+ --go :: Int -> [(Int, a)] -> [a] go _ [] = [] go n ((m, a) : as) = replicate (m - n) blank ++ a : go (m + 1) as