packages feed

ghc-events-analyze 0.2.7 → 0.2.8

raw patch · 10 files changed

+98/−72 lines, 10 filesdep +textdep +th-lift-instancesdep ~SVGFontsdep ~basedep ~bytestring

Dependencies added: text, th-lift-instances

Dependency ranges changed: SVGFonts, base, bytestring, ghc-events, hashable, lens, mtl, optparse-applicative, transformers

Files

ChangeLog view
@@ -1,3 +1,8 @@+0.2.8++  * Support for ghc-events-0.13+    (2020-04-23 Mitsutoshi Aoe <me@maoe.name>)+ 0.2.7    * Support for GHC 8.8
ghc-events-analyze.cabal view
@@ -1,5 +1,5 @@ name:                ghc-events-analyze-version:             0.2.7+version:             0.2.8 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,23 +51,25 @@                        GHC.RTS.Events.Analyze.Reports.Timed                        GHC.RTS.Events.Analyze.Reports.Timed.SVG -  build-depends:       base                 >= 4.9   && < 4.14,+  build-depends:       base                 >= 4.9   && < 4.15,                        blaze-svg            >= 0.3   && < 0.4,-                       bytestring           >= 0.10  && < 0.11,+                       bytestring           >= 0.10  && < 0.12,                        containers           >= 0.5   && < 0.7,                        diagrams-lib         >= 1.3   && < 1.5,                        diagrams-svg         >= 1.1   && < 1.5,                        filepath             >= 1.3   && < 1.5,-                       ghc-events           >= 0.6,+                       ghc-events           >= 0.13  && < 0.14,                        hashable             >= 1.2   && < 1.4,-                       lens                 >= 3.10  && < 4.19,+                       lens                 >= 3.10  && < 4.20,                        mtl                  >= 2.2.1 && < 2.3,-                       optparse-applicative >= 0.11  && < 0.16,+                       optparse-applicative >= 0.11  && < 0.17,                        parsec               >= 3.1   && < 3.2,                        regex-base           >= 0.93  && < 0.95,                        regex-pcre-builtin   >= 0.94  && < 0.96,-                       SVGFonts             >= 1.5   && < 1.8,+                       SVGFonts             >= 1.7   && < 1.8,+                       text                             < 1.3,                        th-lift              >= 0.6   && < 0.9,+                       th-lift-instances    >= 0.1   && < 0.2,                        transformers         >= 0.3   && < 0.6,                        unordered-containers >= 0.2   && < 0.3,                        -- No version: whatever is bundled with ghc
src/GHC/RTS/Events/Analyze/Analysis.hs view
@@ -23,6 +23,8 @@ import qualified Data.IntMap.Strict as IntMap import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty+import Data.Text (Text)+import qualified Data.Text as T  import GHC.RTS.Events (     Event(..)@@ -92,13 +94,13 @@     startId :: EventInfo -> Maybe EventId     startId (RunThread tid)                                   = Just $ EventThread tid     startId StartGC                                           = Just $ EventGC-    startId (UserMessage (prefix optionsUserStart -> Just e)) = Just $ parseUserEvent e+    startId (UserMessage (T.stripPrefix optionsUserStart -> Just e)) = Just $ parseUserEvent e     startId _                                                 = Nothing      stopId :: EventInfo -> Maybe EventId     stopId (StopThread tid _)                               = Just $ EventThread tid     stopId EndGC                                            = Just $ EventGC-    stopId (UserMessage (prefix optionsUserStop -> Just e)) = Just $ parseUserEvent e+    stopId (UserMessage (T.stripPrefix optionsUserStop -> Just e)) = Just $ parseUserEvent e     stopId _                                                = Nothing      nonEmptyTail :: NonEmpty a -> NonEmpty a@@ -192,12 +194,12 @@ -- Record thread creation in current window, and add it to the map of running threads recordThreadCreation :: ThreadId -> Timestamp -> State AnalysisState () recordThreadCreation tid start = do-    let label = show tid+    let label = showThreadId tid     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 -> [Text] -> State EventAnalysis () recordWindowThreadCreation tid start label =     windowThreadInfo . at tid .=  Just (start, start, label) @@ -228,7 +230,7 @@     threads <- use runningThreads     mapM_ (\tid -> cur $ recordWindowThreadFinish tid stop) $ threadIds threads -labelThread :: ThreadId -> String -> State AnalysisState ()+labelThread :: ThreadId -> Text -> State AnalysisState () labelThread tid !l = do     runningThreads . at tid %= fmap (l :)     cur $ windowThreadInfo . at tid %= fmap updThreadInfo
src/GHC/RTS/Events/Analyze/Options.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} module GHC.RTS.Events.Analyze.Options (     Options(..)   , parseOptions
src/GHC/RTS/Events/Analyze/Reports/Timed.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} module GHC.RTS.Events.Analyze.Reports.Timed (     Report   , ReportFragment(..)@@ -9,9 +10,12 @@  import Control.Lens (itoList, (^.), over, each, _3) import Data.Function (on)-import Data.List (group, sortBy, intercalate)+import Data.List (group, sortBy) import Data.IntMap.Strict (IntMap)-import System.IO (Handle, hPutStrLn, withFile, IOMode(WriteMode))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import System.IO (Handle, withFile, IOMode(WriteMode)) import Text.Printf (printf) import qualified Data.HashMap.Strict as Map import qualified Data.IntMap.Strict as IntMap@@ -33,7 +37,7 @@   deriving Show  data ReportLine = ReportLineData {-    lineHeader     :: String+    lineHeader     :: Text   , lineEventIds   :: [EventId]   , lineBackground :: Maybe (Int, Int)   , lineValues     :: IntMap Double@@ -58,7 +62,7 @@       [ReportLine $ sumLines title $ map (reportLine Nothing) (filtered f)]      quantThreadInfoFlattened = over (each._3) flattenThreadLabels quantThreadInfo-    flattenThreadLabels = intercalate ":" . map head . group+    flattenThreadLabels = T.intercalate ":" . map head . group      reportLine :: Maybe Title -> (EventId, IntMap Double) -> ReportLine     reportLine title (eid, qs) = ReportLineData {@@ -102,7 +106,7 @@     combineBG (Just (fr, to)) (Just (fr', to')) = Just (min fr fr', max to to')     combineBG _ _ = Nothing -showTitle :: String -> Maybe Title -> String+showTitle :: a -> Maybe a -> a showTitle _   (Just title) = title showTitle def Nothing      = def @@ -119,17 +123,17 @@     $ 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+    writeLine :: Either Text [Text] -> IO ()+    writeLine (Left header) = T.hPutStrLn h $ "\n" <> header+    writeLine (Right cells) = T.hPutStrLn h $ T.intercalate " " cells -    reportFragment :: ReportFragment -> Either String [String]+    reportFragment :: ReportFragment -> Either Text [Text]     reportFragment (ReportSection title) = Left title     reportFragment (ReportLine line)     = Right (reportLine line) -    reportLine :: ReportLine -> [String]+    reportLine :: ReportLine -> [Text]     reportLine ReportLineData{..} =       lineHeader : unsparse "0.00" (over each showValue lineValues) -    showValue :: Double -> String-    showValue = printf "%0.2f"+    showValue :: Double -> Text+    showValue = T.pack . printf "%0.2f"
src/GHC/RTS/Events/Analyze/Reports/Timed/SVG.hs view
@@ -11,6 +11,7 @@ import GHC.RTS.Events (Timestamp) import Graphics.SVGFonts.Text (TextOpts(..)) import Text.Printf (printf)+import qualified Data.Text as T import qualified Diagrams.Prelude           as D import qualified Graphics.SVGFonts.Fonts    as F import qualified Graphics.SVGFonts.Text     as F@@ -91,12 +92,12 @@ renderFragment options@Options{..} font = go   where     go :: (ReportFragment, Colour Double) -> SVGFragment-    go (ReportSection title,_) = SVGSection (mkSVGText title (optionsBucketHeight + 2) font)+    go (ReportSection title,_) = SVGSection (mkSVGText (T.unpack title) (optionsBucketHeight + 2) font)     go (ReportLine line,c)     = uncurry SVGLine $ renderLine options c line  renderLine :: Options -> Colour Double -> ReportLine -> (String, D) renderLine options@Options{..} lc line@ReportLineData{..} =-    ( lineHeader -- renderText lineHeader (optionsBucketHeight + 2)+    ( T.unpack lineHeader -- renderText lineHeader (optionsBucketHeight + 2)     , blocks lc <> bgBlocks options lineBackground     )   where
src/GHC/RTS/Events/Analyze/Reports/Totals.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module GHC.RTS.Events.Analyze.Reports.Totals (     Report   , ReportFragment(..)@@ -8,9 +9,12 @@  import Control.Lens hiding (filtered) import Data.Function (on)-import Data.List (sortBy, intercalate, group)+import Data.List (sortBy, group)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T import GHC.RTS.Events (Timestamp)-import System.IO (Handle, hPutStrLn, withFile, IOMode(WriteMode))+import System.IO (Handle, withFile, IOMode(WriteMode)) import Text.Printf (printf)  import GHC.RTS.Events.Analyze.Analysis@@ -30,7 +34,7 @@   deriving Show  data ReportLine = ReportLineData {-    lineHeader   :: String+    lineHeader   :: Text   , lineEventIds :: [EventId]   , lineTotal    :: Timestamp   }@@ -54,7 +58,7 @@       [ReportLine $ sumLines title $ map (reportLine Nothing) (filtered f)]      flattenedThreadInfo = over (each._3) flattenThreadLabels _windowThreadInfo-    flattenThreadLabels = intercalate ":" . map head . group+    flattenThreadLabels = T.intercalate ":" . map head . group      reportLine :: Maybe Title -> (EventId, Timestamp) -> ReportLine     reportLine title (eid, total) = ReportLineData {@@ -80,7 +84,7 @@   , lineTotal    = foldr (+) 0 $ map lineTotal qs   } -showTitle :: String -> Maybe Title -> String+showTitle :: Text -> Maybe Title -> Text showTitle _   (Just title) = title showTitle def Nothing      = def @@ -97,19 +101,19 @@     $ 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+    writeLine :: Either Title [Text] -> IO ()+    writeLine (Left header) = T.hPutStrLn h $ "\n" <> header+    writeLine (Right cells) = T.hPutStrLn h $ T.intercalate "   " cells -    reportFragment :: ReportFragment -> Either String [String]+    reportFragment :: ReportFragment -> Either Title [Text]     reportFragment (ReportSection title) = Left title     reportFragment (ReportLine line)     = Right (reportLine line) -    reportLine :: ReportLine -> [String]+    reportLine :: ReportLine -> [Text]     reportLine ReportLineData{..} =       [ lineHeader-      , printf "%dns"   $ lineTotal-      , printf "%0.3fs" $ toSec lineTotal+      , T.pack $ printf "%dns"   $ lineTotal+      , T.pack $ printf "%0.3fs" $ toSec lineTotal       ]      toSec :: Timestamp -> Double
src/GHC/RTS/Events/Analyze/Script.hs view
@@ -23,6 +23,9 @@  import Control.Applicative (optional) import Data.List (intercalate)+import Data.Text (Text)+import qualified Data.Text as T+import Instances.TH.Lift () import Language.Haskell.TH.Lift (deriveLiftMany) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax@@ -44,7 +47,7 @@ type Script a = [Command a]  -- | Title of a section of an event-type Title = String+type Title = Text  -- | A positive (Include) or negative (Exclude) filter data NameFilter a@@ -194,13 +197,13 @@ pScript = whiteSpace *> many1 pCommand <* eof  pCommand :: Parser (Command String)-pCommand = (Section <$> (reserved "section" *> stringLiteral))+pCommand = (Section . T.pack <$> (reserved "section" *> stringLiteral))        <|> (One     <$> pEventId                         <*> pTitle)        <|> (Sum     <$> (reserved "sum" *> pEventFilter) <*> pTitle)        <|> (All     <$> (reserved "all" *> pEventFilter) <*> pEventSort)  pEventId :: Parser EventId-pEventId =  (EventUser     <$> stringLiteral <*> pure 0 <?> "user event")+pEventId =  (EventUser . T.pack <$> stringLiteral <*> pure 0 <?> "user event")         <|> (EventThread   <$> pThreadId     <?> "thread event")         <|> (const EventGC <$> reserved "GC")   where@@ -220,7 +223,7 @@                )  pTitle :: Parser (Maybe Title)-pTitle = optionMaybe (reserved "as" *> stringLiteral)+pTitle = optionMaybe $ T.pack <$> (reserved "as" *> stringLiteral)  pNameFilter :: Parser (NameFilter String) pNameFilter = f <$> optional stringLiteral where
src/GHC/RTS/Events/Analyze/Types.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} module GHC.RTS.Events.Analyze.Types (@@ -43,10 +44,16 @@ import Data.HashMap.Strict (HashMap) import Data.IntMap.Strict (IntMap) import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Read as TR import GHC.Generics import GHC.RTS.Events (Timestamp, ThreadId) import Text.Regex.PCRE+import Text.Regex.PCRE.Text () -- for RegexLike Regex Text +import GHC.RTS.Events.Analyze.Utils (showThreadId)+ {-------------------------------------------------------------------------------   Event identifiers -------------------------------------------------------------------------------}@@ -76,7 +83,7 @@   deriving (Eq, Generic, Hashable, Ord, Show)  -- | The user-readable name for an event-type EventLabel = String+type EventLabel = Text  -- | Event subscript --@@ -97,22 +104,22 @@ -- | Parse user event -- -- If the event name starts with a digit, regard it as a 'EventSubscript'.-parseUserEvent :: String -> EventId+parseUserEvent :: Text -> EventId parseUserEvent s =-    case span isDigit s of-      ([], _ ) -> EventUser s 0-      (ds, cs) -> EventUser (dropWhile isSpace cs) (read ds)+    case TR.decimal s of+      Left _ -> EventUser s 0+      Right (eid, cs) -> EventUser (T.dropWhile isSpace cs) eid  -- | Show an event ID given thread info -- -- The argument is typically either `__threadInfo` from `EventAnalysis` or -- `quantThreadInfo` from `Quantized`.-showEventId :: HashMap ThreadId (a,b,String) -> EventId -> String+showEventId :: HashMap ThreadId (a,b,Text) -> EventId -> Text showEventId _    EventGC             = "GC" showEventId _    (EventUser event _) = event showEventId info (EventThread tid)   = case info ^. at tid of                                          Just (_, _, l) -> l-                                         Nothing        -> show tid+                                         Nothing        -> showThreadId tid  {-------------------------------------------------------------------------------   Options@@ -128,8 +135,8 @@   , optionsGenerateTotalsText :: Bool   , optionsWindowEvent        :: Maybe EventId   , optionsNumBuckets         :: Int-  , optionsUserStart          :: String-  , optionsUserStop           :: String+  , optionsUserStart          :: Text+  , optionsUserStop           :: Text   , optionsScriptTotals       :: FilePath  -- "" denotes the standard script   , optionsScriptTimed        :: FilePath   , optionsGranularity        :: TimelineGranularity@@ -148,7 +155,7 @@  -- Thread labels held by a thread (as indicated by ThreadLabel events) -- in inverse chronological order (most recent first)-type ThreadLabels = [String]+type ThreadLabels = [Text]  -- | Map of currently running threads to their labels type RunningThreads = HashMap ThreadId ThreadLabels
src/GHC/RTS/Events/Analyze/Utils.hs view
@@ -1,20 +1,24 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} module GHC.RTS.Events.Analyze.Utils (     throwLeft   , throwLeftStr   , insertWith-  , prefix   , explode   , mapEithers   , unsparse   , Alignment(..)   , renderTable+  , showThreadId   ) where  import Control.Lens import Control.Exception import Data.List (transpose) import Data.Either (partitionEithers)+import Data.Text (Text)+import qualified Data.Text as T+import GHC.RTS.Events (ThreadId)  throwLeft :: Exception e => IO (Either e a) -> IO a throwLeft act = act >>= \ea -> case ea of Left  e -> throwIO e@@ -45,16 +49,6 @@               (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])@@ -84,24 +78,27 @@ data Alignment = AlignLeft | AlignRight  -- | "Typeset" a table-renderTable :: [Alignment] -> [[String]] -> [[String]]+renderTable :: [Alignment] -> [[Text]] -> [[Text]] renderTable aligns rows = transpose paddedColumns   where-    columns :: [[String]]+    columns :: [[Text]]     columns = transpose rows      columnWidths :: [Int]-    columnWidths = map (maximum . map length) columns+    columnWidths = map (maximum . map T.length) columns -    paddedColumns :: [[String]]+    paddedColumns :: [[Text]]     paddedColumns = map padColumn (zip3 aligns columnWidths columns) -    padColumn :: (Alignment, Int, [String]) -> [String]+    padColumn :: (Alignment, Int, [Text]) -> [Text]     padColumn (align, width, column) = map (padCell align width) column -    padCell :: Alignment -> Int -> String -> String+    padCell :: Alignment -> Int -> Text -> Text     padCell align width cell =-      let padding = replicate (width - length cell) ' '+      let padding = T.replicate (width - T.length cell) " "       in case align of-           AlignLeft  -> cell ++ padding-           AlignRight -> padding ++ cell+           AlignLeft  -> cell <> padding+           AlignRight -> padding <> cell++showThreadId :: ThreadId -> Text+showThreadId = T.pack . show