diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +0.3, released 2019-09-08 + +* Added warnings if eventlog2html is used on eventlogs generated by GHC Version without profiling support. +* Moved to version 0.4 of HVega. +* HeapProfCostCentre and HeapProfSampleCostCentre Events are included in the generated output. + 0.2, released 2019-07-05 * Added the commandline option '-o OUTFILE' which writes the output to diff --git a/eventlog2html.cabal b/eventlog2html.cabal --- a/eventlog2html.cabal +++ b/eventlog2html.cabal @@ -1,5 +1,5 @@ Name: eventlog2html -Version: 0.2.0 +Version: 0.3.0 Synopsis: Visualise an eventlog Description: eventlog2html is a library for visualising eventlogs. At the moment, the intended use is to visualise eventlogs @@ -46,12 +46,13 @@ filepath >= 1.4.2 && < 1.5, ghc-events >= 0.8.0 && < 0.10, hashtables >= 1.2.3 && < 1.3, - hvega >= 0.2.0 && < 0.3, + hvega >= 0.4.0 && < 0.5, mtl >= 2.2.2 && < 2.3, optparse-applicative >= 0.14.3 && < 0.15, semigroups >= 0.18 && < 0.20, text >= 1.2.3 && < 1.3, - time >= 1.8.0 && < 2.0 + time >= 1.8.0 && < 2.0, + vector >= 0.11 GHC-options: -Wall default-language: Haskell2010 diff --git a/src/Eventlog/Data.hs b/src/Eventlog/Data.hs --- a/src/Eventlog/Data.hs +++ b/src/Eventlog/Data.hs @@ -10,7 +10,6 @@ import qualified Eventlog.Events as E import qualified Eventlog.HeapProf as H import Eventlog.Prune (prune, cmpName, cmpSize, cmpStdDev) -import Eventlog.Total (total) import Eventlog.Vega import Eventlog.Types (Header) @@ -23,9 +22,7 @@ Size -> cmpSize StdDev -> cmpStdDev reversing' = if reversing a then swap else id - (ph, fs, traces) <- chunk file - putStrLn (show fs) - let (h, totals) = total ph fs + (h,totals, fs, traces) <- chunk file let keeps = prune cmp 0 (bound $ nBands a) totals let combinedJson = object [ "samples" .= bandsToVega keeps (bands h keeps fs) diff --git a/src/Eventlog/Events.hs b/src/Eventlog/Events.hs --- a/src/Eventlog/Events.hs +++ b/src/Eventlog/Events.hs @@ -3,58 +3,100 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StrictData #-} module Eventlog.Events(chunk) where import GHC.RTS.Events hiding (Header, header) 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 Data.List import Data.Function import Data.Word import Data.Time import Data.Time.Clock.POSIX +import qualified Data.Map as Map +import Data.Vector.Unboxed (Vector, (!?)) +import Data.Maybe +import Data.Version +import Text.ParserCombinators.ReadP +import Control.Monad +import Data.Char +import System.IO +type PartialHeader = Int -> Header + fromNano :: Word64 -> Double fromNano e = fromIntegral e * 1e-9 -chunk :: FilePath -> IO (PartialHeader, [Frame], [Trace]) -chunk f = eventlogToHP . either error id =<< readEventLogFromFile f +chunk :: FilePath -> IO (Header,Map Text (Double, Double), [Frame], [Trace]) +chunk f = do + (EventLog _ e) <- either error id <$> readEventLogFromFile f + (ph, frames, traces) <- eventsToHP e + let (counts, totals) = total frames + return $ (ph counts, totals, frames, traces) -eventlogToHP :: EventLog -> IO (PartialHeader, [Frame], [Trace]) -eventlogToHP (EventLog _h e) = do - eventsToHP e +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 + ++ ", 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 + ++ ", which does not support biographical or retainer profiling." +checkGHCVersion _ = Nothing + eventsToHP :: Data -> IO (PartialHeader, [Frame], [Trace]) eventsToHP (Data es) = do let el@EL{..} = foldEvents 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 + data EL = EL - { pargs :: Maybe [String] - , clocktimeSec :: Word64 - , samples :: Maybe (Word64, [Sample]) - , frames :: [(Word64, [Sample])] - , traces :: [Trace] - , start :: Word64 - , end :: Word64 } deriving Show + { pargs :: !(Maybe [String]) + , ident :: Maybe (Version, String) + , ccMap :: !(Map.Map Word32 CostCentre) + , clocktimeSec :: !Word64 + , samples :: !(Maybe (Word64, [Sample])) + , frames :: ![(Word64, [Sample])] + , traces :: ![Trace] + , start :: !Word64 + , end :: !Word64 } deriving Show +data CostCentre = CC { cid :: Word32 + , label :: Text + , modul :: Text + , loc :: Text } deriving Show + initEL :: Word64 -> EL initEL t = EL { pargs = Nothing + , ident = Nothing , clocktimeSec = 0 , samples = Nothing , frames = [] , traces = [] , start = t , end = 0 + , ccMap = Map.empty } foldEvents :: [Event] -> EL @@ -68,16 +110,44 @@ updateLast t . case e of -- Traces + RtsIdentifier _ ident -> addIdent ident Message s -> addTrace (Trace (fromNano t) (T.pack s)) UserMessage s -> addTrace (Trace (fromNano t) (T.pack s)) HeapProfBegin {} -> addFrame t - --HeapProfCostCentre {} -> False + HeapProfCostCentre cid l m loc _ -> addCostCentre cid (CC cid l m loc) HeapProfSampleBegin {} -> addFrame t - --HeapProfSampleCostCentre {} -> True + 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 +addIdent s el = el { ident = parseIdent s } + +parseIdent :: String -> Maybe (Version, String) +parseIdent s = listToMaybe $ flip readP_to_S s $ do + void $ string "GHC-" + [v1, v2, v3] <- replicateM 3 (intP <* optional (char '.')) + skipSpaces + return (makeVersion [v1,v2,v3]) + where + intP = do + x <- munch1 isDigit + return $ read x + + +addCostCentre :: Word32 -> CostCentre -> EL -> EL +addCostCentre s cc el = el { ccMap = Map.insert s cc (ccMap el) } + +addCCSample :: Word64 -> Word8 -> Vector Word32 -> EL -> EL +addCCSample res _sd st el = + fromMaybe (addSample (Sample "NONE" (fromIntegral res)) el) $ do + cid <- st !? 0 + CC{label, modul} <- Map.lookup cid (ccMap el) + let fmtl = modul <> "." <> label + return $ addSample (Sample fmtl (fromIntegral res)) el + addClocktime :: Word64 -> EL -> EL addClocktime s el = el { clocktimeSec = s } diff --git a/src/Eventlog/HeapProf.hs b/src/Eventlog/HeapProf.hs --- a/src/Eventlog/HeapProf.hs +++ b/src/Eventlog/HeapProf.hs @@ -5,16 +5,19 @@ 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 (PartialHeader, [Frame], [Trace]) +chunk :: FilePath -> IO (Header, Map Text (Double, Double), [Frame], [Trace]) chunk f = do (ph, fs) <- chunkT <$> readFile f + let (counts, totals) = total fs -- Heap profiles do not support traces - return (ph, fs, []) + return (ph counts, totals, fs, []) -chunkT :: Text -> (PartialHeader, [Frame]) +chunkT :: Text -> (Int -> Header, [Frame]) chunkT s = let ls = lines s (hs, ss) = splitAt 4 ls diff --git a/src/Eventlog/Total.hs b/src/Eventlog/Total.hs --- a/src/Eventlog/Total.hs +++ b/src/Eventlog/Total.hs @@ -19,11 +19,11 @@ parse0 :: Parse parse0 = Parse{ symbols = empty, totals = empty, count = 0 } -total :: PartialHeader -> [Frame] -> (Header, Map Text (Double, Double)) -total ph fs = +total :: [Frame] -> (Int, Map Text (Double, Double)) +total fs = let parse1 = flip execState parse0 . mapM_ parseFrame $ fs in ( - ph (count parse1) + count parse1 , fmap (stddev $ fromIntegral (count parse1)) (totals parse1) ) diff --git a/src/Eventlog/Types.hs b/src/Eventlog/Types.hs --- a/src/Eventlog/Types.hs +++ b/src/Eventlog/Types.hs @@ -11,8 +11,6 @@ , hCount :: Int } -type PartialHeader = Int -> Header - data Sample = Sample Text Double deriving Show data Frame = Frame Double [Sample] deriving Show diff --git a/src/Eventlog/VegaTemplate.hs b/src/Eventlog/VegaTemplate.hs --- a/src/Eventlog/VegaTemplate.hs +++ b/src/Eventlog/VegaTemplate.hs @@ -21,9 +21,6 @@ injectJSON :: Text -> Value -> BuildLabelledSpecs injectJSON t val = \x -> x ++ [(t,val)] --- injectJSONs :: [(Text, Value)] -> BuildLabelledSpecs --- injectJSONs ts = \x -> x ++ ts - data AreaChartType = Stacked | Normalized @@ -109,7 +106,7 @@ dataFromSource "data_json_samples" [], VL.mark Line [], encodingLineLayer c [], - transformLineLayer + transformLineLayer [] ] encodingLineLayer :: ChartConfig -> [LabelledSpec] -> (VLProperty, VLSpec) @@ -120,21 +117,12 @@ PScale [SDomain (DSelection "brush")]] . position Y [PName "norm_y", PmType Quantitative, PAxis [AxTitle "Allocation", AxFormat ".1f"]] -transformLineLayer :: (VLProperty, VLSpec) +transformLineLayer :: [LabelledSpec] -> (VLProperty, VLSpec) transformLineLayer = - -- We need to get the `VLTransform` data constructor but it's not - -- exported - let (label, _vs) = transform . filter (FSelection "legend") $ [] - in (label, - toJSON [object ["window" .= [object ["field" .= String "y" - , "op" .= String "max" - , "as" .= String "max_y"]] - , "frame" .= toJSON [Null, Null] - , "groupby" .= toJSON [String "k"]] - , object ["calculate" .= String "datum.y / datum.max_y" - , "as" .= String "norm_y"] - , object ["filter" .= object ["selection" .= String "legend"]]]) - + transform + . window [([WField "y", WAggregateOp Max], "max_y")] [WFrame Nothing Nothing, WGroupBy ["k"]] + . calculateAs "datum.y / datum.max_y" "norm_y" + . filter (FSelection "legend") ----------------------------------------------------------------------------------- -- The Selection Chart @@ -196,8 +184,10 @@ encoding . order [OName "k", OmType Quantitative] . color [MName "c", MmType Nominal, MScale [colourProperty c], MLegend []] - . injectJSON "tooltip" (toJSON [object ["field" .= String "y", "type" .= String "quantitative", "format" .= String "s", "title" .= String "Allocation"], - object ["field" .= String "c", "type" .= String "nominal", "title" .= String "Type"]]) + . tooltips + [ [TName "y", TmType Quantitative, TFormat "s", TTitle "Allocation"] + , [TName "c", TmType Nominal, TTitle "Type"] + ] . position X [PName "x", PmType Quantitative, PAxis [AxTitle ""] , PScale [SDomain (DSelection "brush")]] . position Y [PName "y" @@ -259,15 +249,10 @@ encodingRight = encoding . injectJSON "tooltip" Null - . injectJSON "color" (object [ - ("value", String "lightgray") - , ("condition", object [ - ("aggregate", String "min") - ,("field", String "c") - ,("legend", Null) - ,("selection", String "legend") - ,("type", String "nominal")]) - ]) + . color + [ + MSelectionCondition (SelectionName "legend") [MName "c", MmType Nominal, MAggregate Min, MLegend []] [MString "lightgray"] + ] . position Y [PName "c" , PmType Nominal , PAxis [ AxOrient SRight @@ -276,7 +261,7 @@ , AxGrid False , AxMinExtent 100 , AxMaxExtent 100] - , PSort [(ByField "k"), Descending]] + , PSort [(ByFieldOp "k" Mean), Descending]] selectionRight :: [LabelledSpec] -> (VLProperty, VLSpec) selectionRight =