diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +0.2.5 + + * Add suppor for filtering threads by name, and improve + performance of relabelling. + (2017-03-11 Pepe Iborra ) + 0.2.4 * Fix bug in timeline rendering when using --tick-every diff --git a/ghc-events-analyze.cabal b/ghc-events-analyze.cabal --- a/ghc-events-analyze.cabal +++ b/ghc-events-analyze.cabal @@ -1,5 +1,5 @@ name: ghc-events-analyze -version: 0.2.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 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 @@ -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 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 @@ -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) 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 @@ -138,9 +138,11 @@ , " | INT -- thread event" , " | \"GC\" -- garbage collection" , "" - , " ::= -- single event" - , " | \"user\" -- any user event" - , " | \"thread\" -- any thread event" + , " ::= -- 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\" \"[\" (\",\" )* \"]\"" , "" , " ::= \"total\"" 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 @@ -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" 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 @@ -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 diff --git a/src/GHC/RTS/Events/Analyze/Reports/Totals.hs b/src/GHC/RTS/Events/Analyze/Reports/Totals.hs --- a/src/GHC/RTS/Events/Analyze/Reports/Totals.hs +++ b/src/GHC/RTS/Events/Analyze/Reports/Totals.hs @@ -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 { 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 @@ -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) diff --git a/src/GHC/RTS/Events/Analyze/Script/Standard.hs b/src/GHC/RTS/Events/Analyze/Script/Standard.hs --- a/src/GHC/RTS/Events/Analyze/Script/Standard.hs +++ b/src/GHC/RTS/Events/Analyze/Script/Standard.hs @@ -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 diff --git a/src/GHC/RTS/Events/Analyze/Types.hs b/src/GHC/RTS/Events/Analyze/Types.hs --- a/src/GHC/RTS/Events/Analyze/Types.hs +++ b/src/GHC/RTS/Events/Analyze/Types.hs @@ -1,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