ghc-events-analyze (empty) → 0.2.0
raw patch · 15 files changed
+1532/−0 lines, 15 filesdep +SVGFontsdep +basedep +containerssetup-changed
Dependencies added: SVGFonts, base, containers, diagrams-lib, diagrams-svg, filepath, ghc-events, lens, mtl, optparse-applicative, parsec, template-haskell, th-lift, transformers
Files
- ChangeLog +3/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- ghc-events-analyze.cabal +79/−0
- src/GHC/RTS/Events/Analyze.hs +59/−0
- src/GHC/RTS/Events/Analyze/Analysis.hs +264/−0
- src/GHC/RTS/Events/Analyze/Options.hs +116/−0
- src/GHC/RTS/Events/Analyze/Reports/Timed.hs +130/−0
- src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs +153/−0
- src/GHC/RTS/Events/Analyze/Reports/Totals.hs +113/−0
- src/GHC/RTS/Events/Analyze/Script.hs +240/−0
- src/GHC/RTS/Events/Analyze/Script/Standard.hs +31/−0
- src/GHC/RTS/Events/Analyze/StrictState.hs +57/−0
- src/GHC/RTS/Events/Analyze/Types.hs +149/−0
- src/GHC/RTS/Events/Analyze/Utils.hs +106/−0
+ ChangeLog view
@@ -0,0 +1,3 @@+2014-02-12 Edsko de Vries <edsko@well-typed.com>++ * Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013-2014 Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Edsko de Vries nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghc-events-analyze.cabal view
@@ -0,0 +1,79 @@+name: ghc-events-analyze+version: 0.2.0+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+ profiling modes or tools. It has two major features:+ .+ 1. While ThreadScope shows CPU activity across all your+ cores, ghc-events-analyze shows CPU activity across all+ your Haskell threads.+ .+ 2. It lets you label periods of time during program+ execution (by instrumenting your code with special trace+ calls) and then lets you visualize those time periods or+ get statistics on them.+ .+ It is very useful for profiling code when ghc's normal+ 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. +license: BSD3+license-file: LICENSE+author: Edsko de Vries, Duncan Coutts, Mikolaj Konarski+maintainer: edsko@well-typed.com+copyright: 2013-2014 Well-Typed LLP+category: Development, Profiling, Trace+build-type: Simple+extra-source-files: ChangeLog+cabal-version: >=1.10++source-repository head+ type: git + location: https://github.com/edsko/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+ GHC.RTS.Events.Analyze.StrictState+ GHC.RTS.Events.Analyze.Utils+ GHC.RTS.Events.Analyze.Types+ GHC.RTS.Events.Analyze.Script+ GHC.RTS.Events.Analyze.Script.Standard+ GHC.RTS.Events.Analyze.Reports.Totals+ 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,+ -- No version: whatever is bundled with ghc+ template-haskell++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -rtsopts++ default-extensions: NamedFieldPuns+ RecordWildCards+ NoMonomorphismRestriction+ ScopedTypeVariables+ ViewPatterns+ BangPatterns+ RankNTypes+ MultiParamTypeClasses+ other-extensions: TemplateHaskell+ QuasiQuotes
+ src/GHC/RTS/Events/Analyze.hs view
@@ -0,0 +1,59 @@+module Main where++import Control.Applicative ((<$>))+import Control.Monad (when)+import System.FilePath (replaceExtension, takeFileName)+import Text.Parsec.String (parseFromFile)++import GHC.RTS.Events.Analyze.Analysis+import GHC.RTS.Events.Analyze.Options+import qualified GHC.RTS.Events.Analyze.Reports.Totals as Totals+import qualified GHC.RTS.Events.Analyze.Reports.Timed as Timed+import qualified GHC.RTS.Events.Analyze.Reports.Timed.SVG as TimedSVG+import GHC.RTS.Events.Analyze.Script+import GHC.RTS.Events.Analyze.Script.Standard++main :: IO ()+main = do+ options@Options{..} <- parseOptions+ analysis <- 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+ -> (FilePath -> IO ())+ -> IO ()+ writeReport isEnabled+ scriptName+ newExt+ mkReport = when isEnabled $ do+ let output = replaceExtension (takeFileName optionsInput) newExt+ mkReport output+ putStrLn $ "Generated " ++ output ++ " using " ++ scriptName++ writeReport optionsGenerateTotalsText+ totalsScriptName+ "totals.txt" $ Totals.writeReport totals++ writeReport optionsGenerateTimedSVG+ timedScriptName+ "timed.svg" $ TimedSVG.writeReport options quantized timed++ writeReport optionsGenerateTimedText+ timedScriptName+ "timed.txt" $ Timed.writeReport timed++getScript :: FilePath -> Script -> IO (String, Script)+getScript "" def = return ("default script", def)+getScript path _ = do+ mScript <- parseFromFile pScript path+ case mScript of+ Left err -> fail (show err)+ Right script -> return (path, script)
+ src/GHC/RTS/Events/Analyze/Analysis.hs view
@@ -0,0 +1,264 @@+module GHC.RTS.Events.Analyze.Analysis (+ -- * Auxiliary+ readEventLog+ -- * Basic analysis+ , events+ , threadInfo+ , numThreads+ , analyze+ -- * Using EventAnalysis+ , eventTotal+ , compareEventIds+ -- * Quantization+ , quantize+ ) where++import Prelude hiding (id, log)+import Control.Applicative ((<$>), (<|>))+import Control.Lens ((%=), (.=), use)+import Control.Monad (forM_, when)+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.Types+import GHC.RTS.Events.Analyze.Script++{-------------------------------------------------------------------------------+ Auxiliary+-------------------------------------------------------------------------------}++sortedEvents :: EventLog -> [Event]+sortedEvents (EventLog _header (Data es)) = map ce_event (sortEvents es)++readEventLog :: FilePath -> IO EventLog+readEventLog = throwLeftStr . readEventLogFromFile++{-------------------------------------------------------------------------------+ Basic analysis of the eventlog, making the information more easily accessible.+ In particular, many events come in pairs (start thread/end thread, etc.);+ 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) }+ where+ analyzeEvent :: Event -> State EventAnalysis ()+ analyzeEvent (Event time spec) = 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+ -- Thread info+ CreateThread tid -> recordThreadCreation tid time+ (finishThread -> Just tid) -> recordThreadFinish tid time+ -- Start/end events+ ThreadLabel tid l -> labelThread tid l+ (startId -> Just eid) -> recordEventStart eid time+ (stopId -> Just eid) -> 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 _ = 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 _ = Nothing++-- 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+recordShutdown :: Timestamp -> State EventAnalysis ()+recordShutdown time = shutdown .= Just time++recordEventStart :: EventId -> Timestamp -> State EventAnalysis ()+recordEventStart eid start = do+ (oldValue, newOpen) <- Map.insertLookupWithKey push eid (start, 1) <$> use openEvents+ openEvents .= newOpen+ case (eid, oldValue) of+ -- Pretend user events stop on the _first_ StartGC+ (EventGC, Nothing) -> simulateUserEventsStopAt start+ _ -> return ()+ where+ push _ (_newStart, _newCount) (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+ events %= (:) (eid, start, stop)+ when (eid == EventGC) $ simulateUserEventsStartAt stop+ _ ->+ openEvents .= newOpen+ where+ 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+ forM_ nowOpen $ \(eid, (start, _count)) -> case eid of+ EventGC -> return ()+ EventThread _ -> return ()+ EventUser _ -> events %= (:) (eid, start, stop)++simulateUserEventsStartAt :: Timestamp -> State EventAnalysis ()+simulateUserEventsStartAt newStart = openEvents %= Map.mapWithKey updUserEvent+ where+ updUserEvent :: EventId -> (Timestamp, Int) -> (Timestamp, Int)+ updUserEvent eid (oldStart, count) = case eid of+ EventGC -> (oldStart, count)+ EventThread _ -> (oldStart, count)+ EventUser _ -> (newStart, count)++recordThreadCreation :: ThreadId -> Timestamp -> State EventAnalysis ()+recordThreadCreation tid start =+ threadInfo tid .= Just (start, start, show tid)++recordThreadFinish :: ThreadId -> Timestamp -> State EventAnalysis ()+recordThreadFinish tid stop = do+ -- The "thread finished" doubles as a "thread stop"+ recordEventStop (EventThread tid) stop+ threadInfo tid %= fmap updStop+ where+ updStop (start, _stop, l) = (start, stop, l)++labelThread :: ThreadId -> String -> State EventAnalysis ()+labelThread tid l =+ threadInfo tid %= fmap updLabel+ where+ updLabel (start, stop, l') = (start, stop, l ++ " (" ++ l' ++ ")")++finishThread :: EventInfo -> Maybe ThreadId+finishThread (StopThread tid ThreadFinished) = Just tid+finishThread _ = Nothing++initialEventAnalysis :: EventAnalysis+initialEventAnalysis = EventAnalysis {+ _events = []+ , __threadInfo = Map.empty+ , _openEvents = Map.empty+ , eventTotals = error "eventTotals computed at the end"+ , _startup = Nothing+ , _shutdown = Nothing+ }++computeTotals :: [(EventId, Timestamp, Timestamp)] -> Map EventId Timestamp+computeTotals = go Map.empty+ where+ go :: Map EventId Timestamp+ -> [(EventId, Timestamp, Timestamp)]+ -> Map EventId Timestamp+ go !acc [] = acc+ go !acc ((eid, start, stop) : es) =+ go (Map.insertWith (+) eid (stop - start) acc) es++{-------------------------------------------------------------------------------+ Using EventAnalysis+-------------------------------------------------------------------------------}++-- | 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++-- | Compare event IDs+compareEventIds :: EventAnalysis -> EventSort+ -> EventId -> EventId -> Ordering+compareEventIds analysis sort a b =+ case sort of+ SortByName -> compare a b+ SortByTotal -> compare (eventTotal analysis b) (eventTotal analysis a)++{-------------------------------------------------------------------------------+ Quantization+-------------------------------------------------------------------------------}++quantize :: Int -> EventAnalysis -> Quantized+quantize numBuckets EventAnalysis{..} = Quantized {+ quantTimes = go Map.empty _events+ , quantThreadInfo = Map.map quantizeThreadInfo __threadInfo+ , quantBucketSize = bucketSize+ }+ where+ go :: Map EventId (Map Int Double)+ -> [(EventId, Timestamp, Timestamp)]+ -> Map EventId (Map Int 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+ $ [ (b, delta startBucket endBucket start end b)+ | b <- [startBucket .. endBucket]+ ]++ update :: Maybe (Map Int Double) -> Maybe (Map Int Double)+ update Nothing = Just $ updates+ update (Just old) = let new = Map.unionWith (+) updates old+ in new `seq` Just new++ in go (Map.alter update eid acc) ttimes'++ -- (a, b)+ -- | | ... | |+ -- startBucket endBucket+ --+ -- ^^^+ -- bucket++ delta :: Int -> Int -> Timestamp -> Timestamp -> Int -> Double+ delta startBucket endBucket start end b+ | b == startBucket && startBucket == endBucket =+ t2d (end - start) / t2d bucketSize+ | b == startBucket =+ t2d (bucketEnd b - start) / t2d bucketSize+ | b == endBucket =+ t2d (end - bucketStart b) / t2d bucketSize+ | otherwise =+ 1++ startTime, endTime, bucketSize :: Timestamp+ startTime = fromMaybe (error "_startup not set") _startup+ endTime = fromMaybe (error "_shutdown not set") _shutdown+ bucketSize = (endTime - startTime) `div` fromIntegral numBuckets++ bucketStart, bucketEnd :: Int -> Timestamp+ bucketStart b = startTime + fromIntegral b * bucketSize+ bucketEnd b = bucketStart (b + 1)++ bucket :: Timestamp -> Int+ bucket t = fromIntegral ((t - startTime) `div` bucketSize)++ t2d :: Timestamp -> Double+ t2d = fromInteger . toInteger++ quantizeThreadInfo :: (Timestamp, Timestamp, String) -> (Int, Int, String)+ quantizeThreadInfo (start, stop, label) = (bucket start, bucket stop, label)
+ src/GHC/RTS/Events/Analyze/Options.hs view
@@ -0,0 +1,116 @@+module GHC.RTS.Events.Analyze.Options (+ Options(..)+ , parseOptions+ ) where++import Options.Applicative++import GHC.RTS.Events.Analyze.Types+import GHC.RTS.Events.Analyze.Script+import GHC.RTS.Events.Analyze.Script.Standard++parseOptions :: IO Options+parseOptions = customExecParser (prefs showHelpOnError) opts+ where+ opts = info (helper <*> parserOptions)+ ( fullDesc+ <> progDesc "Quantize and visualize EVENTLOG"+ <> footer "If no output is selected, generates SVG and totals."+ )++parserOptions :: Parser Options+parserOptions =+ infoOption scriptHelp ( long "help-script"+ <> help "Detailed information about scripts"+ )+ <*> (selectDefaultOutput <$> (Options+ <$> switch ( long "timed"+ <> help "Generate timed report (in SVG format)"+ )+ <*> switch ( long "timed-txt"+ <> help "Generate timed report (in textual format)"+ )+ <*> switch ( long "totals"+ <> help "Generate totals report"+ )+ <*> option ( long "buckets"+ <> short 'b'+ <> metavar "INT"+ <> help "Use INT buckets for quantization."+ <> showDefault+ <> value 100+ )+ <*> strOption ( long "start"+ <> metavar "STR"+ <> help "Use STR as the prefix for the start of user events"+ <> showDefault+ <> value "START "+ )+ <*> strOption ( long "stop"+ <> metavar "STR"+ <> help "Use STR as the prefix for the end of user events"+ <> showDefault+ <> value "STOP "+ )+ <*> strOption ( long "script-totals"+ <> metavar "PATH"+ <> help "Use the script in PATH for the totals report"+ <> value ""+ )+ <*> strOption ( long "script-timed"+ <> metavar "PATH"+ <> help "Use the script in PATH for the timed reports"+ <> value ""+ )+ <*> argument str (metavar "EVENTLOG")+ ))++scriptHelp :: String+scriptHelp = unlines [+ "Scripts are used to drive report generation. The syntax for scripts is"+ , ""+ , "<script> ::= <command>+"+ , ""+ , "<command> ::= \"section\" STRING"+ , " | <eventId> (\"as\" STRING)?"+ , " | \"sum\" <filter> (\"as\" STRING)?"+ , " | <filter> (\"by\" <sort>)?"+ , ""+ , "<eventId> ::= STRING -- user event"+ , " | INT -- thread event"+ , " | \"GC\" -- garbage collection"+ , ""+ , "<filter> ::= <eventId> -- single event"+ , " | \"user\" -- any user event"+ , " | \"thread\" -- any thread event"+ , " | \"any\" \"[\" <filter> (\",\" <filter>)* \"]\""+ , ""+ , "<sort> ::= \"total\""+ , " | \"name\""+ , ""+ , "The default script for the timed reports is\n"+ ]+ ++ indent (unparseScript defaultScriptTimed)+ ++ "\nThe default script for the totals report is\n\n"+ ++ indent (unparseScript defaultScriptTotals)+ ++ unlines [+ "\nCustom scripts are useful extract different kinds of data from the"+ , "eventlog, or for presentation purposes."+ ]+ where+ indent :: [String] -> String+ indent = unlines . map (" " ++)++-- | Select which output is active if no output is selected at all+selectDefaultOutput :: Options -> Options+selectDefaultOutput options@Options{..} =+ if noOutputSelected+ then options { optionsGenerateTotalsText = True+ , optionsGenerateTimedSVG = True+ , optionsGenerateTimedText = True+ }+ else options+ where+ noOutputSelected = not optionsGenerateTotalsText+ && not optionsGenerateTimedSVG+ && not optionsGenerateTimedText
+ src/GHC/RTS/Events/Analyze/Reports/Timed.hs view
@@ -0,0 +1,130 @@+module GHC.RTS.Events.Analyze.Reports.Timed (+ Report+ , ReportFragment(..)+ , ReportLine(..)+ , createReport+ , writeReport+ ) where++import Data.Function (on)+import Data.List (sortBy, intercalate)+import Data.Map (Map)+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.Script+import GHC.RTS.Events.Analyze.Types+import GHC.RTS.Events.Analyze.Utils++{-------------------------------------------------------------------------------+ Types+-------------------------------------------------------------------------------}++type Report = [ReportFragment]++data ReportFragment =+ ReportSection Title+ | ReportLine ReportLine+ deriving Show++data ReportLine = ReportLineData {+ lineHeader :: String+ , lineEventIds :: [EventId]+ , lineBackground :: Maybe (Int, Int)+ , lineValues :: Map Int Double+ }+ deriving Show++{-------------------------------------------------------------------------------+ Report generation+-------------------------------------------------------------------------------}++createReport :: EventAnalysis -> Quantized -> Script -> Report+createReport analysis Quantized{..} = concatMap go+ where+ go :: Command -> [ReportFragment]+ go (Section title) =+ [ReportSection title]+ go (One eid title) =+ [ReportLine $ reportLine title (eid, quantTimesForEvent eid)]+ go (All f sort) =+ map (ReportLine . reportLine Nothing) (sorted sort $ filtered f)+ go (Sum f title) =+ [ReportLine $ sumLines title $ map (reportLine Nothing) (filtered f)]++ reportLine :: Maybe Title -> (EventId, Map Int Double) -> ReportLine+ reportLine title (eid, qs) = ReportLineData {+ lineHeader = showTitle (showEventId quantThreadInfo eid) title+ , lineEventIds = [eid]+ , lineBackground = background eid+ , lineValues = qs+ }++ -- For threads we draw a background showing the thread's lifetime+ background :: EventId -> Maybe (Int, Int)+ background EventGC = Nothing+ background (EventUser _) = Nothing+ background (EventThread tid) =+ case Map.lookup tid quantThreadInfo of+ Just (start, stop, _) -> Just (start, stop)+ Nothing -> error $ "Invalid thread ID " ++ show tid++ 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)+ 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)++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+ }+ where+ combineBG :: Maybe (Int, Int) -> Maybe (Int, Int) -> Maybe (Int, Int)+ combineBG (Just (fr, to)) (Just (fr', to')) = Just (min fr fr', max to to')+ combineBG _ _ = Nothing++showTitle :: String -> Maybe Title -> String+showTitle _ (Just title) = title+showTitle def Nothing = def++{-------------------------------------------------------------------------------+ Write the report in textual form+-------------------------------------------------------------------------------}++writeReport :: Report -> FilePath -> IO ()+writeReport report path = withFile path WriteMode $ writeReport' report++writeReport' :: Report -> Handle -> IO ()+writeReport' report h =+ mapM_ writeLine+ $ mapEithers id (renderTable (AlignLeft : repeat AlignRight))+ $ map reportFragment report+ where+ writeLine :: Either String [String] -> IO ()+ writeLine (Left header) = hPutStrLn h $ "\n" ++ header+ writeLine (Right cells) = hPutStrLn h $ intercalate " " cells++ reportFragment :: ReportFragment -> Either String [String]+ reportFragment (ReportSection title) = Left title+ reportFragment (ReportLine line) = Right (reportLine line)++ reportLine :: ReportLine -> [String]+ reportLine ReportLineData{..} =+ lineHeader : map showValue (unsparse 0 lineValues)++ showValue :: Double -> String+ showValue = printf "%0.2f"
+ src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs view
@@ -0,0 +1,153 @@+module GHC.RTS.Events.Analyze.Reports.Timed.SVG (+ writeReport+ ) where++import Data.Maybe (catMaybes)+import Data.Monoid (mempty, mconcat, (<>))+import Diagrams.Backend.SVG (B, renderSVG)+import Diagrams.Prelude (Diagram, Colour, R2, SizeSpec2D, (#), (|||))+import GHC.RTS.Events (Timestamp)+import Graphics.SVGFonts.ReadFont (TextOpts(..))+import Text.Printf (printf)+import qualified Data.Map as Map+import qualified Diagrams.Prelude as D+import qualified Graphics.SVGFonts.ReadFont as F++import GHC.RTS.Events.Analyze.Types+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++type D = Diagram B R2++renderReport :: Options -> Quantized -> Report -> (SizeSpec2D, D)+renderReport Options{optionsNumBuckets}+ Quantized{quantBucketSize}+ report = (D.sizeSpec2D rendered, rendered)+ where+ rendered :: D+ rendered = D.vcat $ map renderSVGFragment (SVGTimeline : fragments)++ fragments :: [SVGFragment]+ fragments = map renderFragment report++ renderSVGFragment :: SVGFragment -> D+ renderSVGFragment (SVGSection title) =+ padHeader (2 * blockSize) title+ renderSVGFragment (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 :: Double -> D -> D+ padHeader height h =+ D.translateX (0.5 * blockSize) h+ <> D.rect headerWidth height # D.alignL # D.lw 0++ headerWidth :: Double+ headerWidth = blockSize -- extra padding+ + (maximum . catMaybes . map headerWidthOf $ fragments)++ headerWidthOf :: SVGFragment -> Maybe Double+ headerWidthOf (SVGLine header _) = Just (D.width header)+ headerWidthOf _ = Nothing++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++renderLine :: ReportLine -> (D, D)+renderLine line@ReportLineData{..} =+ ( renderText lineHeader (blockSize + 2)+ , blocks <> bgBlocks lineBackground+ )+ where+ blocks :: D+ blocks = mconcat . map (mkBlock $ lineColor 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+++bgBlocks :: Maybe (Int, Int) -> D+bgBlocks Nothing = mempty+bgBlocks (Just (fr, to)) = mconcat [+ block b # D.fcA (D.black `D.withOpacity` 0.1)+ | b <- [fr .. to]+ ]++renderText :: String -> Double -> D+renderText str size =+ D.stroke (F.textSVG' (textOpts str size)) # D.fc D.black # D.lc D.black # D.alignL++textOpts :: String -> Double -> TextOpts+textOpts str size =+ TextOpts {+ txt = str+ , fdo = F.lin+ , mode = F.INSIDE_H+ , spacing = F.KERN+ , underline = False+ , textWidth = 0 -- not important+ , textHeight = size+ }++-- | Translate quantized value to opacity+--+-- For every event and every bucket we record the percentage of that bucket+-- that the event was using. However, if we use this percentage directly as the+-- opacity value for the corresponding block in the diagram then a thread that+-- does _something_, but only a tiny amount, is indistinguishable from a thread+-- that does nothing -- but typically we are interested in knowing that a+-- thread does something, anything at all, rather than nothing, while the+-- difference between using 30% and 40% is probably less important and hard to+-- visually see anyway.+qOpacity :: Double -> Double+qOpacity 0 = 0+qOpacity q = 0.1 + q * 0.9++block :: Int -> D+block i = D.translateX (blockSize * fromIntegral i)+ $ D.rect blockSize blockSize++blockSize :: Double+blockSize = 10++timeline :: Int -> Timestamp -> D+timeline numBuckets bucketSize =+ mconcat [ timelineBlock b # D.translateX (fromIntegral b * blockSize)+ | b <- [0 .. numBuckets - 1]+ ]+ where+ 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++ bucketTime :: Int -> String+ bucketTime b = let timeNs :: Timestamp+ timeNs = fromIntegral b * bucketSize++ timeS :: Double+ timeS = fromIntegral timeNs / 1000000000+ in printf "%0.1fs" timeS++ bigLine = mkLine [(0, 4), (blockSize, 0)]+ smallLine = mkLine [(0, 3), (blockSize, 0)]+ mkLine = D.fromSegments . map (D.straight . D.r2)
+ src/GHC/RTS/Events/Analyze/Reports/Totals.hs view
@@ -0,0 +1,113 @@+module GHC.RTS.Events.Analyze.Reports.Totals (+ Report+ , ReportFragment(..)+ , ReportLine(..)+ , createReport+ , writeReport+ ) where++import Data.Function (on)+import Data.List (sortBy, intercalate)+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+import GHC.RTS.Events.Analyze.Script+import GHC.RTS.Events.Analyze.Utils++{-------------------------------------------------------------------------------+ Types+-------------------------------------------------------------------------------}++type Report = [ReportFragment]++data ReportFragment =+ ReportSection Title+ | ReportLine ReportLine+ deriving Show++data ReportLine = ReportLineData {+ lineHeader :: String+ , lineEventIds :: [EventId]+ , lineTotal :: Timestamp+ }+ deriving Show++{-------------------------------------------------------------------------------+ Report generation+-------------------------------------------------------------------------------}++createReport :: EventAnalysis -> Script -> Report+createReport analysis@EventAnalysis{..} = concatMap go+ where+ go :: Command -> [ReportFragment]+ go (Section title) =+ [ReportSection title]+ go (One eid title) =+ [ReportLine $ reportLine title (eid, totalForEvent eid)]+ go (All f sort) =+ map (ReportLine . reportLine Nothing) (sorted sort $ filtered f)+ go (Sum f title) =+ [ReportLine $ sumLines title $ map (reportLine Nothing) (filtered f)]++ reportLine :: Maybe Title -> (EventId, Timestamp) -> ReportLine+ reportLine title (eid, total) = ReportLineData {+ lineHeader = showTitle (showEventId __threadInfo eid) title+ , lineEventIds = [eid]+ , lineTotal = total+ }++ totalForEvent :: EventId -> Timestamp+ totalForEvent = eventTotal analysis++ sorted :: Maybe EventSort -> [(EventId, a)] -> [(EventId, a)]+ 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)++sumLines :: Maybe Title -> [ReportLine] -> ReportLine+sumLines title qs = ReportLineData {+ lineHeader = showTitle "TOTAL" title+ , lineEventIds = concatMap lineEventIds qs+ , lineTotal = foldr (+) 0 $ map lineTotal qs+ }++showTitle :: String -> Maybe Title -> String+showTitle _ (Just title) = title+showTitle def Nothing = def++{-------------------------------------------------------------------------------+ Write report in textual form+-------------------------------------------------------------------------------}++writeReport :: Report -> FilePath -> IO ()+writeReport report path = withFile path WriteMode $ writeReport' report++writeReport' :: Report -> Handle -> IO ()+writeReport' report h =+ mapM_ writeLine+ $ mapEithers id (renderTable (AlignLeft : repeat AlignRight))+ $ map reportFragment report+ where+ writeLine :: Either String [String] -> IO ()+ writeLine (Left header) = hPutStrLn h $ "\n" ++ header+ writeLine (Right cells) = hPutStrLn h $ intercalate " " cells++ reportFragment :: ReportFragment -> Either String [String]+ reportFragment (ReportSection title) = Left title+ reportFragment (ReportLine line) = Right (reportLine line)++ reportLine :: ReportLine -> [String]+ reportLine ReportLineData{..} =+ [ lineHeader+ , printf "%dns" $ lineTotal+ , printf "%0.3fs" $ toSec lineTotal+ ]++ toSec :: Timestamp -> Double+ toSec = (/ 1000000000) . fromInteger . toInteger
+ src/GHC/RTS/Events/Analyze/Script.hs view
@@ -0,0 +1,240 @@+{-# OPTIONS_GHC -w -W #-}+{-# LANGUAGE TemplateHaskell #-}+module GHC.RTS.Events.Analyze.Script (+ -- * Types+ Script+ , Title+ , EventFilter(..)+ , EventSort(..)+ , Command(..)+ -- * Script execution+ , matchesFilter+ -- * Parsing and unparsing+ , pScript+ , unparseScript+ -- * Quasi-quoting support+ , scriptQQ+ ) where++import Control.Applicative ((<$>), (<*>), (*>), (<*))+import Data.List (intercalate)+import Data.Word (Word32)+import Language.Haskell.TH.Lift (deriveLiftMany)+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Text.Parsec+import Text.Parsec.Language (haskellDef)+import qualified Text.Parsec.Token as P++import GHC.RTS.Events.Analyze.Types++{-------------------------------------------------------------------------------+ Script definition+-------------------------------------------------------------------------------}++-- | A script is used to drive the construction of reports+type Script = [Command]++-- | Title of a section of an event+type Title = String++-- | Event filters+data EventFilter =+ -- | A single event+ --+ -- Examples+ -- > GC -- the GC event+ -- > "foo" -- user event "foo"+ -- > 5 -- thread ID 5+ Is EventId++ -- | Any user event+ --+ -- Example+ -- > user+ | IsUser++ -- | Any thread event+ --+ -- Example+ -- > thread+ | IsThread++ -- | Logical or+ --+ -- Example+ -- > [GC, "foo", 5]+ | Any [EventFilter]+ deriving Show++-- | Sorting+data EventSort =+ -- | Sort by event name+ --+ -- Example+ -- > thread by name+ SortByName++ -- | Sort by total+ --+ -- Example+ -- > user by name+ | SortByTotal+ deriving Show++-- | Commands+data Command =+ -- | Start a new section+ --+ -- Example+ -- > section "User events"+ Section Title++ -- | A single event+ --+ -- Example+ -- > "foo" -- user event "foo"+ | One EventId (Maybe Title)++ -- | Show all the matching events+ --+ -- Examples+ -- > user by total -- all user events, sorted+ -- > [4, 2, 3] -- thread events 4, 2 and 3, in that order+ | All EventFilter (Maybe EventSort)++ -- | Sum over the specified events+ --+ -- Example+ -- > sum user+ | Sum EventFilter (Maybe Title)+ deriving Show++{-------------------------------------------------------------------------------+ Script execution+-------------------------------------------------------------------------------}++matchesFilter :: EventFilter -> 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)++{-------------------------------------------------------------------------------+ Lexical analysis+-------------------------------------------------------------------------------}++lexer :: P.TokenParser ()+lexer = P.makeTokenParser haskellDef {+ P.reservedNames = [+ "section"+ , "GC"+ , "user"+ , "thread"+ , "as"+ , "by"+ , "total"+ , "name"+ , "all"+ ]+ }++reserved = P.reserved lexer+stringLiteral = P.stringLiteral lexer+natural = P.natural lexer+squares = P.squares lexer+commaSep1 = P.commaSep1 lexer+whiteSpace = P.whiteSpace lexer++{-------------------------------------------------------------------------------+ Syntax analysis+-------------------------------------------------------------------------------}++type Parser a = Parsec String () a++pEventId :: Parser EventId+pEventId = (EventUser <$> stringLiteral <?> "user event")+ <|> (EventThread <$> pThreadId <?> "thread event")+ <|> (const EventGC <$> reserved "GC")+ where+ pThreadId = fromIntegral <$> natural++pEventFilter :: Parser EventFilter+pEventFilter = (Is <$> pEventId)+ <|> (const IsUser <$> reserved "user")+ <|> (const IsThread <$> reserved "thread")+ <|> (Any <$> (squares $ commaSep1 pEventFilter))++pCommand :: Parser Command+pCommand = (Section <$> (reserved "section" *> stringLiteral))+ <|> (One <$> pEventId <*> pTitle)+ <|> (Sum <$> (reserved "sum" *> pEventFilter) <*> pTitle)+ <|> (All <$> (reserved "all" *> pEventFilter) <*> pEventSort)++pEventSort :: Parser (Maybe EventSort)+pEventSort = optionMaybe $ reserved "by" *> (+ (const SortByTotal <$> reserved "total")+ <|> (const SortByName <$> reserved "name")+ )++pTitle :: Parser (Maybe Title)+pTitle = optionMaybe (reserved "as" *> stringLiteral)++pScript :: Parser Script+pScript = whiteSpace *> many1 pCommand <* eof++{-------------------------------------------------------------------------------+ Quasi-quoting+-------------------------------------------------------------------------------}++$(deriveLiftMany [''EventId, ''EventFilter, ''EventSort, ''Command])++instance Lift Word32 where+ lift = let conv :: Word32 -> Int ; conv = fromEnum in lift . conv++scriptQQ :: QuasiQuoter+scriptQQ = QuasiQuoter {+ quoteExp = \e -> parseScriptString "<<source>>" e >>= lift+ , quotePat = \_ -> fail "Cannot use script as a pattern"+ , quoteType = \_ -> fail "Cannot use script as a type"+ , quoteDec = \_ -> fail "Cannot use script as a declaration"+ }++parseScriptString :: Monad m => String -> String -> m Script+parseScriptString source input =+ case runParser pScript () source input of+ Left err -> fail (show err)+ Right script -> return script++{-------------------------------------------------------------------------------+ Unparsing+-------------------------------------------------------------------------------}++unparseScript :: Script -> [String]+unparseScript = concatMap unparseCommand++unparseCommand :: Command -> [String]+unparseCommand (Section title) = ["", title]+unparseCommand (One eid title) = [unparseEventId eid ++ " " ++ unparseTitle title]+unparseCommand (All f sort) = ["all " ++ unparseFilter f ++ " " ++ unparseSort sort]+unparseCommand (Sum f title) = ["sum " ++ unparseFilter f ++ " " ++ unparseTitle title]++unparseEventId :: EventId -> String+unparseEventId EventGC = "GC"+unparseEventId (EventUser e) = e+unparseEventId (EventThread tid) = show tid++unparseTitle :: Maybe Title -> String+unparseTitle Nothing = ""+unparseTitle (Just t) = "as " ++ t++unparseSort :: Maybe EventSort -> String+unparseSort Nothing = ""+unparseSort (Just SortByName) = "by name"+unparseSort (Just SortByTotal) = "by total"++unparseFilter :: EventFilter -> String+unparseFilter (Is eid) = unparseEventId eid+unparseFilter IsUser = "user"+unparseFilter IsThread = "thread"+unparseFilter (Any fs) = "[" ++ intercalate "," (map unparseFilter fs) ++ "]"
+ src/GHC/RTS/Events/Analyze/Script/Standard.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE QuasiQuotes #-}+module GHC.RTS.Events.Analyze.Script.Standard (+ defaultScriptTotals+ , defaultScriptTimed+ ) where++import GHC.RTS.Events.Analyze.Script++defaultScriptTotals :: Script+defaultScriptTotals = [scriptQQ|+ GC++ section "USER EVENTS (user events are corrected for GC)"+ all user by total+ sum user++ section "THREAD EVENTS"+ all thread by name+ sum thread+ |]++defaultScriptTimed :: Script+defaultScriptTimed = [scriptQQ|+ GC++ section "USER EVENTS"+ all user by name++ section "THREAD EVENTS"+ all thread by name+ |]
+ src/GHC/RTS/Events/Analyze/StrictState.hs view
@@ -0,0 +1,57 @@+-- | State monad which forces the state to whnf on every step+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}+module GHC.RTS.Events.Analyze.StrictState (+ -- * Transformer+ StateT+ , runStateT+ , evalStateT+ , execStateT+ -- * Base monad+ , State+ , runState+ , evalState+ , execState+ -- * Re-exports+ , module Control.Monad.State.Strict+ ) where++import Control.Monad.IO.Class (MonadIO)+import Control.Monad.State.Strict (MonadState(..))+import qualified Control.Monad.State.Strict as St+import Control.Monad.Trans.Class (MonadTrans)+import Control.Monad.Identity (Identity(..))++{-------------------------------------------------------------------------------+ Transformer+-------------------------------------------------------------------------------}++newtype StateT s m a = StateT { unStateT :: St.StateT s m a }+ deriving (Functor, Monad, MonadTrans, MonadIO)++runStateT :: StateT s m a -> s -> m (a, s)+runStateT = St.runStateT . unStateT++evalStateT :: Monad m => StateT s m a -> s -> m a+evalStateT = St.evalStateT . unStateT++execStateT :: Monad m => StateT s m a -> s -> m s+execStateT = St.execStateT . unStateT++instance Monad m => MonadState s (StateT s m) where+ get = StateT get+ put s = s `seq` StateT (put s)++{-------------------------------------------------------------------------------+ Base monad+-------------------------------------------------------------------------------}++type State s a = StateT s Identity a++runState :: State s a -> s -> (a, s)+runState act = runIdentity . runStateT act++evalState :: State s a -> s -> a+evalState act = runIdentity . evalStateT act++execState :: State s a -> s -> s+execState act = runIdentity . execStateT act
+ src/GHC/RTS/Events/Analyze/Types.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE TemplateHaskell #-}+module GHC.RTS.Events.Analyze.Types (+ EventId(..)+ , Options(..)+ , EventAnalysis(..)+ , events+ , threadInfo+ , openEvents+ , startup+ , shutdown+ , numThreads+ , Quantized(..)+ , showEventId+ , isUserEvent+ , isThreadEvent+ ) where++import Control.Lens (Lens', makeLenses, at, (^.))+import Data.Map (Map)+import GHC.RTS.Events (Timestamp, ThreadId)+import qualified Data.Map as Map++-- | Event identifiers+--+-- The order of the constructors matters because it dictates the default+-- ordering in the output SVG+data EventId =+ -- | Garbage collection+ EventGC++ -- | User events+ --+ -- To use user events, do+ --+ -- > traceEventIO "START <label>"+ -- > ...+ -- > traceEventIO "STOP <label>"+ | EventUser String++ -- | Threads+ | EventThread ThreadId+ deriving (Eq, Ord, Show)++-- | Command line options+data Options = Options {+ optionsGenerateTimedSVG :: Bool+ , optionsGenerateTimedText :: Bool+ , optionsGenerateTotalsText :: Bool+ , optionsNumBuckets :: Int+ , optionsUserStart :: String+ , optionsUserStop :: String+ , optionsScriptTotals :: FilePath -- "" denotes the standard script+ , optionsScriptTimed :: FilePath+ -- Defined last to make defining the parser easier+ , optionsInput :: FilePath+ }+ deriving Show++-- The fields that we use as "accumulators" in `analyze` are strict so that we+-- don't build up chains of EventAnalysis objects when we update it as we+-- process the eventlog+data EventAnalysis = EventAnalysis {+ -- | Start and stop timestamps+ --+ -- For events that miss an end marker the @stop@ timestamp will be set to+ -- be equal to the @start@ timestamp+ _events :: ![(EventId, Timestamp, Timestamp)]++ -- | Information about each thread+ --+ -- When was the thread created, when was it destroyed, and what is the+ -- thread label (as indicated by ThreadLabel events)+ --+ -- The default label for each thread is the thread ID+ , __threadInfo :: !(Map ThreadId (Timestamp, Timestamp, String))++ -- | Event with a start but with a missing end.+ --+ -- Some events may be self-overlapping+ --+ -- > Start <event>+ -- > ..+ -- > Start <event>+ -- > ..+ -- > End <event>+ -- > ..+ -- > End <event>+ --+ -- (this happens in particular for GC events because GC events are listed+ -- 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))++ -- | Total amount of time per event (non-strict)+ , eventTotals :: Map EventId Timestamp++ -- | Timestamp of the Startup event+ , _startup :: !(Maybe Timestamp)++ -- | Timestamp of the Shutdown event+ , _shutdown :: !(Maybe Timestamp)+ }+ deriving Show++$(makeLenses ''EventAnalysis)++threadInfo :: ThreadId -> Lens' EventAnalysis (Maybe (Timestamp, Timestamp, String))+threadInfo tid = _threadInfo . at tid++numThreads :: EventAnalysis -> Int+numThreads analysis = Map.size (analysis ^. _threadInfo)++-- | Quantization splits the total time up into @n@ buckets. We record for each+-- event and each bucket what percentage of that bucket the event used. A+-- missing entry denotes 0.+--+-- Quantization is essential because each individual event period might be too+-- small to show+--+-- For any given bucket the sum of all threads for that bucket cannot exceed the+-- 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)+ -- | Like threadInfo, but quantized (start and finish bucket)+ , quantThreadInfo :: Map ThreadId (Int, Int, String)+ -- | Size of each bucket+ , quantBucketSize :: Timestamp+ }+ deriving Show++-- | Show an event ID given the specified options (for renaming events)+-- and information about threads (either `__threadInfo` from `EventAnalysis` or+-- `quantThreadInfo` from `Quantized`).+showEventId :: Map ThreadId (a, a, String) -> EventId -> String+showEventId _ EventGC = "GC"+showEventId _ (EventUser event) = event+showEventId info (EventThread tid) = case Map.lookup tid info of+ Just (_, _, l) -> l+ Nothing -> show tid++isUserEvent :: EventId -> Bool+isUserEvent (EventUser _) = True+isUserEvent _ = False++isThreadEvent :: EventId -> Bool+isThreadEvent (EventThread _) = True+isThreadEvent _ = False
+ src/GHC/RTS/Events/Analyze/Utils.hs view
@@ -0,0 +1,106 @@+module GHC.RTS.Events.Analyze.Utils (+ throwLeft+ , throwLeftStr+ , insertWith+ , prefix+ , explode+ , mapEithers+ , unsparse+ , Alignment(..)+ , renderTable+ ) where++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+ Right a -> return a++throwLeftStr :: IO (Either String a) -> IO a+throwLeftStr = throwLeft . fmap (either (Left . userError) Right)++-- | Like `Map.insertWith`, but for associative lists+--+-- > updateAssocs f key val [.. (key, val') ..] == [.. (key, val' `f` val) ..]+-- > updateAssocs f key val assocs == assocs ++ [(key, val)]+insertWith :: Eq a => (b -> b -> b) -> a -> b -> [(a, b)] -> [(a, b)]+insertWith f key val = go+ where+ go [] = [(key, val)]+ go ((key', val') : assocs)+ | key == key' = (key, val' `f` val) : assocs+ | otherwise = (key', val') : go assocs++-- | Like PHP's explode function+--+-- > explode ',' "abc,def,ghi" == ["abc","def","ghi"]+explode :: Eq a => a -> [a] -> [[a]]+explode needle = go+ where+ go xs = case break (== needle) xs of+ (before, []) -> [before]+ (before, _ : after) -> before : go after++-- | Check if a string has a given prefix+--+-- > prefix "abc" "abcdef" == Just "def"+-- > prefix "abc" "defabc" == Nothing+prefix :: String -> String -> Maybe String+prefix [] ys = Just ys+prefix _ [] = Nothing+prefix (x:xs) (y:ys) | x == y = prefix xs ys+ | otherwise = Nothing++mapEithers :: forall a b c d.+ ([a] -> [c])+ -> ([b] -> [d])+ -> [Either a b]+ -> [Either c d]+mapEithers f g eithers = rebuild eithers (f lefts) (g rights)+ where+ (lefts, rights) = partitionEithers eithers++ rebuild :: [Either a b] -> [c] -> [d] -> [Either c d]+ rebuild [] [] [] = []+ rebuild (Left _ : es) (x : xs) ys = Left x : rebuild es xs ys+ rebuild (Right _ : es) xs (y : ys) = Right y : rebuild es xs ys+ rebuild _ _ _ = error "mapEithers: lengths changed"++-- | 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+ where+ go :: Int -> [(Int, a)] -> [a]+ go _ [] = []+ go n ((m, a) : as) = replicate (m - n) blank ++ a : go (m + 1) as++-- | Alignment options for `renderTable`+data Alignment = AlignLeft | AlignRight++-- | "Typeset" a table+renderTable :: [Alignment] -> [[String]] -> [[String]]+renderTable aligns rows = transpose paddedColumns+ where+ columns :: [[String]]+ columns = transpose rows++ columnWidths :: [Int]+ columnWidths = map (maximum . map length) columns++ paddedColumns :: [[String]]+ paddedColumns = map padColumn (zip3 aligns columnWidths columns)++ padColumn :: (Alignment, Int, [String]) -> [String]+ padColumn (align, width, column) = map (padCell align width) column++ padCell :: Alignment -> Int -> String -> String+ padCell align width cell =+ let padding = replicate (width - length cell) ' '+ in case align of+ AlignLeft -> cell ++ padding+ AlignRight -> padding ++ cell