diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,14 @@ +0.4, released 2019-09-18 + +* BREAKING CHANGE: eventlog2html no longer includes traces which have been generated by "traceEvent" or "traceEventIO" from "Debug.Trace" by default. + "traceEvent" and "traceEventIO" are supposed to be used for high-frequency events. + If you want to trace low-frequency events, especially in order to relate phases of your program to memory usage patterns, use "traceMarker" and "traceMarkerIO" instead. + If you want to return to the old behaviour, add the "--include-trace-events" option on the commandline. +* Removed "trace PERCENT" option, which had no effect in the code. +* Added warning about eventlogs with a lot of traces. +* Added option to filter the traces which should be included in the + generated output. + 0.3, released 2019-09-08 * Added warnings if eventlog2html is used on eventlogs generated by GHC Version without profiling support. diff --git a/eventlog2html.cabal b/eventlog2html.cabal --- a/eventlog2html.cabal +++ b/eventlog2html.cabal @@ -1,5 +1,5 @@ Name: eventlog2html -Version: 0.3.0 +Version: 0.4.0 Synopsis: Visualise an eventlog Description: eventlog2html is a library for visualising eventlogs. At the moment, the intended use is to visualise eventlogs @@ -31,7 +31,7 @@ cabal-version: 1.18 extra-doc-files: README.md CHANGELOG -Tested-With: GHC ==8.6.4 +Tested-With: GHC ==8.6.5 Library Build-depends: diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -6,17 +6,15 @@ import Data.Aeson (encodeFile, Value, toJSON) import System.FilePath import System.Exit +import System.IO -import Eventlog.Args (args, Args(..), Sort(..)) +import Eventlog.Args (args, Args(..)) import Eventlog.Bands (bands) -import qualified Eventlog.Events as E -import qualified Eventlog.HeapProf as H import Eventlog.HtmlTemplate -import Eventlog.Prune (prune, cmpName, cmpSize, cmpStdDev) -import Eventlog.Total (total) import Eventlog.Data import Eventlog.Vega import Eventlog.VegaTemplate +import Eventlog.Types main :: IO () main = do @@ -33,7 +31,7 @@ | otherwise -> doOneHtml a fin fout argsToOutput _ = die "When the -o option is specified, exactly one eventlog file has to be passed." - + doOneJson :: Args -> FilePath -> FilePath -> IO () doOneJson a fin fout = do (_, val) <- generateJson fin a @@ -41,7 +39,14 @@ doOneHtml :: Args -> FilePath -> FilePath -> IO () doOneHtml a fin fout = do - (header, data_json) <- generateJson fin a + (header, data_json) <- generateJsonValidate checkTraces fin a let html = templateString header data_json a writeFile fout html + where + checkTraces :: ProfData -> IO () + checkTraces (ProfData _ _ _ ts) = + if length ts > 1000 + then hPutStrLn stderr + "More than 1000 traces, consider reducing using -i or -x" + else return () diff --git a/src/Eventlog/Args.hs b/src/Eventlog/Args.hs --- a/src/Eventlog/Args.hs +++ b/src/Eventlog/Args.hs @@ -18,13 +18,16 @@ { sorting :: Sort , reversing :: Bool - , tracePercent :: Double , nBands :: Int , heapProfile :: Bool , noIncludejs :: Bool , json :: Bool , noTraces :: Bool + , traceEvents :: Bool -- ^ By default, only traceMarkers are included. + -- This option enables the inclusion of traceEvents. , userColourScheme :: Text + , includeStr :: [Text] + , excludeStr :: [Text] , outputFile :: Maybe String , files :: [String] } @@ -40,12 +43,6 @@ ( long "reverse" <> help "Reverse the order of bands." ) <*> option auto - ( long "trace" - <> help "Percentage of trace elements to combine." - <> value 1 - <> showDefault - <> metavar "PERCENT" ) - <*> option auto ( long "bands" <> help "Maximum number of bands to draw (0 for unlimited)." <> value 15 @@ -65,10 +62,30 @@ <*> switch ( long "no-traces" <> help "Don't display traces on chart") + <*> switch + ( long "include-trace-events" + <> help ("Enables the inclusion of traces emitted using `traceEvent`" + ++ ", which should only be used for high-frequency events. " + ++ "For low frequency events, use `traceMarker` instead.") + <> showDefault) <*> option str ( long "colour-scheme" <> value "category20b" <> help "The name of the colour scheme. See the vega documentation (https://vega.github.io/vega/docs/schemes/#reference) for a complete list. Examples include \"category10\" \"dark2\" \"tableau10\". ") + <*> many (option str + (short 'i' + <> long "include" + <> help ("Specify the traces which should be included in the output. Only traces which contain SUBSTRING " + ++ "in their name will be included. Multiple different traces can be included " + ++ "with \"-i foo -i bar\".") + <> metavar "SUBSTRING")) + <*> many (option str + (short 'x' + <> long "exclude" + <> help ("Specify the traces which should be excluded in the output. All traces which contain SUBSTRING " + ++ "in their name will be excluded. Multiple different traces can be excluded " + ++ "with \"-x foo -x bar\".") + <> metavar "SUBSTRING")) <*> (optional $ option str (short 'o' <> help "Write the output to the given filename." diff --git a/src/Eventlog/Data.hs b/src/Eventlog/Data.hs --- a/src/Eventlog/Data.hs +++ b/src/Eventlog/Data.hs @@ -1,37 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} -module Eventlog.Data (generateJson) where +module Eventlog.Data (generateJson, generateJsonValidate ) where import Prelude hiding (print, readFile) import Data.Aeson (Value(..), (.=), object) -import Data.Tuple (swap) -import Eventlog.Args (Args(..), Sort(..)) +import Eventlog.Args (Args(..)) import Eventlog.Bands (bands) import qualified Eventlog.Events as E import qualified Eventlog.HeapProf as H -import Eventlog.Prune (prune, cmpName, cmpSize, cmpStdDev) +import Eventlog.Prune (prune) import Eventlog.Vega -import Eventlog.Types (Header) +import Eventlog.Types (Header, ProfData(..)) -generateJson :: FilePath -> Args -> IO (Header, Value) -generateJson file a = do - let chunk = if heapProfile a then H.chunk else E.chunk - cmp = fst $ reversing' sorting' - sorting' = case sorting a of - Name -> cmpName - Size -> cmpSize - StdDev -> cmpStdDev - reversing' = if reversing a then swap else id - (h,totals, fs, traces) <- chunk file - let keeps = prune cmp 0 (bound $ nBands a) totals - let combinedJson = object [ +generateJsonValidate :: (ProfData -> IO ()) -> FilePath -> Args -> IO (Header, Value) +generateJsonValidate validate file a = do + let chunk = if heapProfile a then H.chunk else E.chunk a + dat@(ProfData h totals fs traces) <- chunk file + validate dat + let keeps = prune a totals + combinedJson = object [ "samples" .= bandsToVega keeps (bands h keeps fs) , "traces" .= tracesToVega traces ] return (h, combinedJson) -bound :: Int -> Int -bound n - | n <= 0 = maxBound - | otherwise = n +generateJson :: FilePath -> Args -> IO (Header, Value) +generateJson = generateJsonValidate (const (return ())) diff --git a/src/Eventlog/Events.hs b/src/Eventlog/Events.hs --- a/src/Eventlog/Events.hs +++ b/src/Eventlog/Events.hs @@ -11,10 +11,10 @@ import Prelude hiding (init, lookup) import qualified Data.Text as T import Data.Text (Text) -import Data.Map (Map) import Eventlog.Types import Eventlog.Total +import Eventlog.Args (Args(..)) import Data.List import Data.Function import Data.Word @@ -34,40 +34,40 @@ fromNano :: Word64 -> Double fromNano e = fromIntegral e * 1e-9 -chunk :: FilePath -> IO (Header,Map Text (Double, Double), [Frame], [Trace]) -chunk f = do +chunk :: Args -> FilePath -> IO ProfData +chunk a f = do (EventLog _ e) <- either error id <$> readEventLogFromFile f - (ph, frames, traces) <- eventsToHP e + (ph, frames, traces) <- eventsToHP a e let (counts, totals) = total frames - return $ (ph counts, totals, frames, traces) + return $ (ProfData (ph counts) totals frames traces) checkGHCVersion :: EL -> Maybe String checkGHCVersion EL { ident = Just (version,_)} | version <= makeVersion [8,4,4] = - Just $ "Warning: The eventlog has been generated with GHC version " - ++ show version + Just $ "Warning: The eventlog has been generated with ghc-" + ++ showVersion version ++ ", which does not support profiling events in the eventlog." checkGHCVersion EL { pargs = Just args, ident = Just (version,_)} | version > makeVersion [8,4,4] && version <= makeVersion [8,9,0] && ("-hr" `elem` args || "-hb" `elem` args) = - Just $ "Warning: The eventlog has been generated with GHC version" - ++ show version + Just $ "Warning: The eventlog has been generated with ghc-" + ++ showVersion version ++ ", which does not support biographical or retainer profiling." checkGHCVersion _ = Nothing -eventsToHP :: Data -> IO (PartialHeader, [Frame], [Trace]) -eventsToHP (Data es) = do +eventsToHP :: Args -> Data -> IO (PartialHeader, [Frame], [Trace]) +eventsToHP a (Data es) = do let - el@EL{..} = foldEvents es + el@EL{..} = foldEvents a es fir = Frame (fromNano start) [] las = Frame (fromNano end) [] mapM_ (hPutStrLn stderr) (checkGHCVersion el) return $ (elHeader el, fir : reverse (las: normalise frames) , traces) -normalise :: [(Word64, [Sample])] -> [Frame] -normalise fs = map (\(t, ss) -> Frame (fromNano t) ss) fs +normalise :: [FrameEL] -> [Frame] +normalise fs = map (\(FrameEL t ss) -> Frame (fromNano t) ss) fs data EL = EL @@ -75,12 +75,14 @@ , ident :: Maybe (Version, String) , ccMap :: !(Map.Map Word32 CostCentre) , clocktimeSec :: !Word64 - , samples :: !(Maybe (Word64, [Sample])) - , frames :: ![(Word64, [Sample])] + , samples :: !(Maybe FrameEL) + , frames :: ![FrameEL] , traces :: ![Trace] , start :: !Word64 , end :: !Word64 } deriving Show +data FrameEL = FrameEL Word64 [Sample] deriving Show + data CostCentre = CC { cid :: Word32 , label :: Text , modul :: Text @@ -99,27 +101,33 @@ , ccMap = Map.empty } -foldEvents :: [Event] -> EL -foldEvents (e:es) = - let res = foldl' folder (initEL (evTime e)) (e:es) +foldEvents :: Args -> [Event] -> EL +foldEvents a (e:es) = + let res = foldl' (folder a) (initEL (evTime e)) (e:es) in addFrame 0 res -foldEvents [] = error "Empty event log" +foldEvents _ [] = error "Empty event log" -folder :: EL -> Event -> EL -folder el (Event t e _) = el & +folder :: Args -> EL -> Event -> EL +folder a el (Event t e _) = el & updateLast t . case e of -- Traces + -- Messages and UserMessages correspond to high-frequency "traceEvent" or "traceEventIO" events from Debug.Trace and + -- are only included if "--include-trace-events" has been specified. + -- For low-frequency events "traceMarker" or "traceMarkerIO" should be used, which generate "UserMarker" events. + Message s -> if traceEvents a then addTrace a (Trace (fromNano t) (T.pack s)) else id + UserMessage s -> if traceEvents a then addTrace a (Trace (fromNano t) (T.pack s)) else id + UserMarker s -> addTrace a (Trace (fromNano t) (T.pack s)) + -- Information about the program RtsIdentifier _ ident -> addIdent ident - Message s -> addTrace (Trace (fromNano t) (T.pack s)) - UserMessage s -> addTrace (Trace (fromNano t) (T.pack s)) + ProgramArgs _ as -> addArgs as + WallClockTime _ s _ -> addClocktime s + -- Profiling Events HeapProfBegin {} -> addFrame t HeapProfCostCentre cid l m loc _ -> addCostCentre cid (CC cid l m loc) HeapProfSampleBegin {} -> addFrame t HeapProfSampleCostCentre _hid r d s -> addCCSample r d s HeapProfSampleString _hid res k -> addSample (Sample k (fromIntegral res)) - ProgramArgs _ as -> addArgs as - WallClockTime _ s _ -> addClocktime s _ -> id addIdent :: String -> EL -> EL @@ -155,23 +163,49 @@ addArgs :: [String] -> EL -> EL addArgs as el = el { pargs = Just as } -addTrace :: Trace -> EL -> EL -addTrace t el = el { traces = t : traces el } +-- | Decide whether to include a trace based on the "includes" and +-- "excludes" options. +-- +-- If a trace satisfies an `-i` flag then it is certainly included. +-- +-- For example for a trace called "eventlog2html" then `-i eventlog -x +-- html` will still include the trace because the `-i` option matches. +-- +-- If a trace doesn't match an `-i` flag then it is excluded if it matches +-- a `-x` flag. +-- +filterTrace :: [Text] -> [Text] -> Trace -> Bool +filterTrace [] [] _ = True +filterTrace [] excludes (Trace _ trc) = + not (any (flip T.isInfixOf trc) excludes) +filterTrace includes [] (Trace _ trc) = + any (flip T.isInfixOf trc) includes +filterTrace includes excludes (Trace _ trc) = + any (flip T.isInfixOf trc) includes + || not (any (flip T.isInfixOf trc) excludes) + +addTrace :: Args -> Trace -> EL -> EL +addTrace a t el | noTraces a = el + | prop t = el { traces = t : traces el } + | otherwise = el + where + prop = filterTrace (includeStr a) (excludeStr a) + addFrame :: Word64 -> EL -> EL addFrame t el = - el { samples = Just (t, []) + el { samples = Just (FrameEL t []) , frames = sampleToFrames (samples el) (frames el) } -sampleToFrames :: Maybe (Word64, [Sample]) -> [(Word64, [Sample])] - -> [(Word64, [Sample])] -sampleToFrames (Just (t, ss)) fs = (t, (reverse ss)) : fs +sampleToFrames :: Maybe FrameEL -> [FrameEL] + -> [FrameEL] +sampleToFrames (Just (FrameEL t ss)) fs = FrameEL t (reverse ss) : fs sampleToFrames Nothing fs = fs addSample :: Sample -> EL -> EL addSample s el = el { samples = go <$> (samples el) } where - go (t, ss) = (t, (s:ss)) + go (FrameEL t ss) = FrameEL t (s:ss) updateLast :: Word64 -> EL -> EL updateLast t el = el { end = t } diff --git a/src/Eventlog/HeapProf.hs b/src/Eventlog/HeapProf.hs --- a/src/Eventlog/HeapProf.hs +++ b/src/Eventlog/HeapProf.hs @@ -5,17 +5,16 @@ import Data.Text (Text, lines, init, drop, length, isPrefixOf, unpack, words, pack) import Data.Text.IO (readFile) import Data.Attoparsec.Text (parseOnly, double) -import Data.Map (Map) import Eventlog.Total import Eventlog.Types -chunk :: FilePath -> IO (Header, Map Text (Double, Double), [Frame], [Trace]) +chunk :: FilePath -> IO ProfData chunk f = do (ph, fs) <- chunkT <$> readFile f let (counts, totals) = total fs -- Heap profiles do not support traces - return (ph counts, totals, fs, []) + return (ProfData (ph counts) totals fs []) chunkT :: Text -> (Int -> Header, [Frame]) chunkT s = diff --git a/src/Eventlog/Prune.hs b/src/Eventlog/Prune.hs --- a/src/Eventlog/Prune.hs +++ b/src/Eventlog/Prune.hs @@ -1,23 +1,23 @@ module Eventlog.Prune ( prune - , Compare - , cmpName - , cmpSize - , cmpStdDev ) where import Data.Text (Text) -import Data.List (foldl', sortBy) +import Data.List (sortBy) import Data.Ord (comparing) import Data.Map.Strict (Map, toList, fromList) +import Eventlog.Args (Args(..), Sort(..)) + type Compare a = a -> a -> Ordering -cmpName, cmpSize, cmpStdDev - :: (Compare (Text, (Double, Double)), Compare (Text, (Double, Double))) -cmpName = (cmpNameAscending, cmpNameDescending) -cmpSize = (cmpSizeDescending, cmpSizeAscending) -cmpStdDev = (cmpStdDevDescending, cmpStdDevAscending) +getComparison :: Args -> Compare (Text, (Double, Double)) +getComparison Args { sorting = Size, reversing = False } = cmpSizeDescending +getComparison Args { sorting = Size, reversing = True } = cmpSizeAscending +getComparison Args { sorting = StdDev, reversing = False } = cmpStdDevDescending +getComparison Args { sorting = StdDev, reversing = True } = cmpStdDevAscending +getComparison Args { sorting = Name, reversing = True } = cmpNameDescending +getComparison Args { sorting = Name, reversing = False } = cmpNameAscending cmpNameAscending, cmpNameDescending, cmpStdDevAscending, cmpStdDevDescending, @@ -29,17 +29,18 @@ cmpSizeAscending = comparing (fst . snd) cmpSizeDescending = flip cmpSizeAscending -prune :: Compare (Text, (Double, Double)) -> Double -> Int -> Map Text (Double, Double) -> Map Text Int -prune cmp tracePercent nBands ts = +prune :: Args -> Map Text (Double, Double) -> Map Text Int +prune args ts = let ccTotals = sortBy cmpSizeDescending (toList ts) sizes = map (fst . snd) ccTotals - total = sum' sizes - limit = if tracePercent == 0 then total - else (1 - tracePercent / 100) * total + limit = sum sizes bigs = takeWhile (< limit) . scanl (+) 0 $ sizes - bands = zipWith const ccTotals $ take nBands bigs - ccs = map fst (sortBy cmp bands) + bands = zipWith const ccTotals $ take (bound $ nBands args) bigs + ccs = map fst (sortBy (getComparison args) bands) in fromList (reverse ccs `zip` [1 ..]) -sum' :: [Double] -> Double -sum' = foldl' (+) 0 +bound :: Int -> Int +bound n + | n <= 0 = maxBound + | otherwise = n + diff --git a/src/Eventlog/Total.hs b/src/Eventlog/Total.hs --- a/src/Eventlog/Total.hs +++ b/src/Eventlog/Total.hs @@ -2,7 +2,7 @@ module Eventlog.Total (total) where import Control.Monad.State.Strict (State(), execState, get, put, modify) -import Data.Map (Map, empty, lookup, insert, alter) +import Data.Map (Map, empty, alter) import Prelude hiding (init, lookup, lines, words, drop, length, readFile) import Data.Text (Text) @@ -11,13 +11,12 @@ data Parse = Parse - { symbols :: !(Map Text Text) -- intern symbols to save RAM - , totals :: !(Map Text (Double, Double)) -- compute running totass and total of squares + { totals :: !(Map Text (Double, Double)) -- compute running totass and total of squares , count :: !Int -- number of frames } parse0 :: Parse -parse0 = Parse{ symbols = empty, totals = empty, count = 0 } +parse0 = Parse{ totals = empty, count = 0 } total :: [Frame] -> (Int, Map Text (Double, Double)) total fs = @@ -39,13 +38,7 @@ inserter :: Sample -> State Parse Double inserter (Sample k v) = do p <- get - k' <- case lookup k (symbols p) of - Nothing -> do - put $! p{ symbols = insert k k (symbols p) } - return k - Just kk -> return kk - p' <- get - put $! p'{ totals = alter (accum v) k' (totals p') } + put $! p { totals = alter (accum v) k (totals p) } return $! v accum :: Double -> Maybe (Double, Double) -> Maybe (Double, Double) diff --git a/src/Eventlog/Types.hs b/src/Eventlog/Types.hs --- a/src/Eventlog/Types.hs +++ b/src/Eventlog/Types.hs @@ -1,6 +1,7 @@ module Eventlog.Types where import Data.Text (Text) +import Data.Map (Map) data Header = Header @@ -17,3 +18,5 @@ -- | A trace we also want to show on the graph data Trace = Trace Double Text deriving Show + +data ProfData = ProfData Header (Map Text (Double, Double)) [Frame] [Trace]