diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +0.2.8 + + * Support for ghc-events-0.13 + (2020-04-23 Mitsutoshi Aoe ) + 0.2.7 * Support for GHC 8.8 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.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 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 @@ -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 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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module GHC.RTS.Events.Analyze.Options ( Options(..) , parseOptions 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,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" 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 @@ -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 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 @@ -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 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 @@ -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 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,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 diff --git a/src/GHC/RTS/Events/Analyze/Utils.hs b/src/GHC/RTS/Events/Analyze/Utils.hs --- a/src/GHC/RTS/Events/Analyze/Utils.hs +++ b/src/GHC/RTS/Events/Analyze/Utils.hs @@ -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