diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,4 +1,9 @@ -0.8.3 +0.9 release 2021-03-17 + +* Add support for -hi profiling +* Add a chart to show memory usage vs live bytes + +0.8.3 release 2020-12-29 * Add `defaultArgs` and `generateJsonData` for using eventlog2html as a library * Update to hvega-0.11 diff --git a/eventlog2html.cabal b/eventlog2html.cabal --- a/eventlog2html.cabal +++ b/eventlog2html.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 Name: eventlog2html -Version: 0.8.3 +Version: 0.9.0 Synopsis: Visualise an eventlog Description: eventlog2html is a library for visualising eventlogs. At the moment, the intended use is to visualise eventlogs @@ -43,7 +43,7 @@ containers >= 0.5.0 && < 0.7, file-embed >= 0.0.11 && < 0.1, filepath >= 1.4.2 && < 1.5, - ghc-events >= 0.13.0 && < 0.14, + ghc-events >= 0.16.0 && < 0.17, hashtables >= 1.2.3 && < 1.3, hvega >= 0.11.0 && < 0.12, mtl >= 2.2.2 && < 2.3, diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -45,7 +45,7 @@ writeFile fout html where checkTraces :: ProfData -> IO () - checkTraces (ProfData _ _ _ _ ts _) = + checkTraces (ProfData _ _ _ _ ts _ _) = if length ts > 1000 then hPutStrLn stderr "More than 1000 traces, consider reducing using -i or -x" diff --git a/src/Eventlog/Data.hs b/src/Eventlog/Data.hs --- a/src/Eventlog/Data.hs +++ b/src/Eventlog/Data.hs @@ -19,12 +19,13 @@ import Text.Blaze.Html generateJsonData :: Args -> ProfData -> IO (Header, Value, Maybe Value, Maybe Html) -generateJsonData a (ProfData h binfo ccMap fs traces _ipes) = do +generateJsonData a (ProfData h binfo ccMap fs traces heap_info ipes) = do let keeps = pruneBands a binfo bs = bands h (Map.map fst keeps) fs combinedJson = object [ "samples" .= bandsToVega keeps bs , "traces" .= tracesToVega traces + , "heap" .= heapToVega heap_info ] mdescs = sortBy (flip (comparing (fst . snd))) $ Map.toList keeps @@ -34,7 +35,7 @@ _ -> Nothing let use_ipes = case hHeapProfileType h of - --Just HeapProfBreakdownInfoTable -> Just ipes + Just HeapProfBreakdownInfoTable -> Just ipes _ -> Nothing desc_buckets = pruneDetailed a binfo bs' = bands h (Map.map fst desc_buckets) fs diff --git a/src/Eventlog/Detailed.hs b/src/Eventlog/Detailed.hs --- a/src/Eventlog/Detailed.hs +++ b/src/Eventlog/Detailed.hs @@ -59,7 +59,7 @@ numTh "Slope" numTh "Fit (R²)" Map.foldrWithKey (\k a res -> renderEntry k a >> res) (mempty :: Html) cs - H.script $ preEscapedToHtml (initTable (isJust mipes)) + H.script $ preEscapedToHtml initTable where numTh lbl = H.th ! H.dataAttribute "sortas" "numeric" $ lbl trunc :: Double -> Fixed E2 @@ -88,7 +88,6 @@ H.td "" H.td "" H.td "" - H.td "" renderEntry (Bucket k) (mitl, (n, BucketInfo _ _ tot std mg)) = do let (a, b, r2) = @@ -114,10 +113,10 @@ rdouble = T.pack . showFixed True . realToFrac @Double @(Fixed E2) renderLine (x,y) = rdouble x <> ":" <> rdouble y -initTable :: Bool -> T.Text -initTable b = "$(document).ready(function() {\ +initTable :: T.Text +initTable = "$(document).ready(function() {\ \$(\".closureTable\").fancyTable({\ - \ sortColumn:" <> (if b then "8" else "3") <> ",\ + \ sortColumn: 1,\ \ pagination: true,\ \ perPage:10,\ \ globalSearch:false,\ diff --git a/src/Eventlog/Events.hs b/src/Eventlog/Events.hs --- a/src/Eventlog/Events.hs +++ b/src/Eventlog/Events.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeApplications #-} module Eventlog.Events(chunk) where -import GHC.RTS.Events hiding (Header, header) +import GHC.RTS.Events hiding (Header, header, liveBytes, blocksSize) import Prelude hiding (init, lookup) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -31,7 +31,6 @@ import qualified Data.Trie.Map as Trie import Data.Map.Merge.Lazy import Data.Functor.Identity -import GHC.Exts.Heap.ClosureTypes type PartialHeader = Int -> Header @@ -42,7 +41,7 @@ chunk :: Args -> FilePath -> IO ProfData chunk a f = do (EventLog _ e) <- either error id <$> readEventLogFromFile f - (ph, bucket_map, ccMap, frames, traces, ipes) <- eventsToHP a e + (ph, bucket_map, ccMap, frames, traces, ipes, hdata) <- eventsToHP a e let (counts, totals) = total frames -- If both keys are present, combine combine = zipWithAMatched (\_ (t, mt) (tot, sd, g) -> Identity $ BucketInfo t mt tot sd g) @@ -55,7 +54,7 @@ combineMissingDesc (Bucket t) (tot, sd, g) = Identity (BucketInfo t Nothing tot sd g) binfo = merge (traverseMissing combineMissingTotal) (traverseMissing combineMissingDesc) combine bucket_map totals - return $ (ProfData (ph counts) binfo ccMap frames traces ipes) + return $ (ProfData (ph counts) binfo ccMap frames traces hdata ipes) checkGHCVersion :: EL -> Maybe Text checkGHCVersion EL { ident = Just (version,_)} @@ -72,14 +71,15 @@ <> ", which does not support biographical or retainer profiling." checkGHCVersion _ = Nothing -eventsToHP :: Args -> Data -> IO (PartialHeader, BucketMap, Map.Map Word32 CostCentre, [Frame], [Trace], Map.Map InfoTablePtr InfoTableLoc) +eventsToHP :: Args -> Data -> IO (PartialHeader, BucketMap, Map.Map Word32 CostCentre, [Frame], [Trace], Map.Map InfoTablePtr InfoTableLoc, HeapInfo) eventsToHP a (Data es) = do let el@EL{..} = foldEvents a es fir = Frame (fromNano start) [] las = Frame (fromNano end) [] mapM_ (T.hPutStrLn stderr) (checkGHCVersion el) - return $ (elHeader el, elBucketMap el, ccMap, fir : reverse (las: normalise frames) , traces, Map.fromList ipes) + let heapInfo = HeapInfo (reverse heapSize) (reverse blocksSize) (reverse liveBytes) + return $ (elHeader el, elBucketMap el, ccMap, fir : reverse (las: normalise frames) , reverse traces, Map.fromList ipes, heapInfo) normalise :: [FrameEL] -> [Frame] normalise = map (\(FrameEL t ss) -> Frame (fromNano t) ss) @@ -89,6 +89,9 @@ data EL = EL { pargs :: !(Maybe [Text]) , programInvocation :: !(Maybe FilePath) + , heapSize :: ![HeapSample] + , liveBytes :: ![HeapSample] + , blocksSize :: ![HeapSample] , ident :: Maybe (Version, Text) , samplingRate :: !(Maybe Word64) , heapProfileType :: !(Maybe HeapProfBreakdown) @@ -142,6 +145,9 @@ , heapProfileType = Nothing , clocktimeSec = 0 , samples = Nothing + , heapSize = [] + , liveBytes = [] + , blocksSize = [] , frames = [] , traces = [] , ipes = [] @@ -182,17 +188,18 @@ HeapBioProfSampleBegin { heapProfSampleTime = t' } -> addFrame t' HeapProfSampleCostCentre _hid r d s -> addCCSample r d s HeapProfSampleString _hid res k -> addSample (Sample (Bucket k) (fromIntegral res)) - --IPE ptr name desc ty lbl smod sloc -> addInfoTableLoc (InfoTablePtr ptr, - -- InfoTableLoc name (parseClosureType desc) ty lbl smod sloc) + InfoTableProv ptr name desc ty lbl smod sloc -> addInfoTableLoc (InfoTablePtr ptr, + InfoTableLoc name (parseClosureType desc) ty lbl smod sloc) + HeapSize _ b -> addHeapSize t b + HeapLive _ b -> addHeapLive t b + BlocksSize _ b -> addBlocksSize t b _ -> id -_parseClosureType :: Text -> ClosureType --- IPEs do not distinguish different CONSTR types, yet -_parseClosureType "0" = CONSTR -_parseClosureType ct = toEnum . read @Int . T.unpack $ ct +parseClosureType :: Int -> ClosureType +parseClosureType ct = toEnum ct -_addInfoTableLoc :: (InfoTablePtr, InfoTableLoc) -> EL -> EL -_addInfoTableLoc itl el = el { ipes = itl : ipes el } +addInfoTableLoc :: (InfoTablePtr, InfoTableLoc) -> EL -> EL +addInfoTableLoc itl el = el { ipes = itl : ipes el } addHeapProfBegin :: Word64 -> HeapProfBreakdown -> EL -> EL addHeapProfBegin sr hptype el = el { samplingRate = Just sr, heapProfileType = Just hptype } @@ -231,7 +238,16 @@ addInvocation :: String -> EL -> EL addInvocation inv el = el { programInvocation = Just inv } +addHeapLive :: Timestamp -> Word64 -> EL -> EL +addHeapLive t s el = el { liveBytes = HeapSample (fromNano t) s : liveBytes el } +addHeapSize :: Timestamp -> Word64 -> EL -> EL +addHeapSize t s el = el { heapSize = HeapSample (fromNano t) s : heapSize el } + +addBlocksSize :: Timestamp -> Word64 -> EL -> EL +addBlocksSize t s el = el { blocksSize = HeapSample (fromNano t) s : blocksSize el} + + -- | Decide whether to include a trace based on the "includes" and -- "excludes" options. -- @@ -295,5 +311,3 @@ elBucketMap :: EL -> BucketMap elBucketMap = bucketMap - - diff --git a/src/Eventlog/HeapProf.hs b/src/Eventlog/HeapProf.hs --- a/src/Eventlog/HeapProf.hs +++ b/src/Eventlog/HeapProf.hs @@ -17,7 +17,7 @@ -- Heap profiles don't contain any other information than the simple bucket name binfo = Map.mapWithKey (\(Bucket k) (t,s,g) -> BucketInfo k Nothing t s g) totals -- Heap profiles do not support traces - return (ProfData (ph counts) binfo mempty fs [] mempty) + return (ProfData (ph counts) binfo mempty fs [] (HeapInfo [] [] []) mempty) chunkT :: Text -> (Int -> Header, [Frame]) chunkT s = diff --git a/src/Eventlog/HtmlTemplate.hs b/src/Eventlog/HtmlTemplate.hs --- a/src/Eventlog/HtmlTemplate.hs +++ b/src/Eventlog/HtmlTemplate.hs @@ -46,27 +46,28 @@ , "console.log(colour_scheme);" ] -data_sets :: IncludeTraceData -> [Text] -data_sets itd = ["res.view.insert(\"data_json_samples\", data_json.samples)"] - ++ ["; res.view.insert(\"data_json_traces\", data_json.traces)" | TraceData <- [itd] ] +data_sets :: [Text] -> [Text] +data_sets itd = Prelude.map line itd + where + line t = "res.view.insert(\"data_json_" <> t <>"\", data_json."<> t <>");" data IncludeTraceData = TraceData | NoTraceData -encloseScript :: IncludeTraceData -> VizID -> Text -> Html -encloseScript = encloseScriptX True +encloseScript :: [Text] -> VizID -> Text -> Html +encloseScript = encloseScriptX -encloseRawVegaScript :: IncludeTraceData -> VizID -> Text -> Html -encloseRawVegaScript = encloseScriptX False +encloseRawVegaScript :: VizID -> Text -> Html +encloseRawVegaScript = encloseScriptX [] -encloseScriptX :: Bool -> IncludeTraceData -> VizID -> Text -> Html -encloseScriptX insert_data_sets itd vid vegaspec = preEscapedToHtml $ T.unlines ([ +encloseScriptX :: [Text] -> VizID -> Text -> Html +encloseScriptX insert_data_sets vid vegaspec = preEscapedToHtml $ T.unlines ([ "var yourVlSpec" `append` vidt `append`"= " `append` vegaspec `append` ";" , "vegaEmbed('#vis" `append` vidt `append` "', yourVlSpec" `append` vidt `append` ")" , ".then((res) => { " ] -- For the 4 vega lite charts we dynamically insert the data after the -- chart is created to avoid duplicating it. For the vega chart, this -- causes a harmless error so we just don't do it. - ++ (if insert_data_sets then data_sets itd else []) ++ + ++ (data_sets insert_data_sets) ++ [ "; res.view.resize()" , "; res.view.runAsync()" , "})" ]) @@ -146,47 +147,60 @@ button ! class_ "tablink button-black" ! onclick "changeTab('normalizedchart', this)" $ "Normalized" button ! class_ "tablink button-black" ! onclick "changeTab('streamgraph', this)" $ "Streamgraph" button ! class_ "tablink button-black" ! onclick "changeTab('linechart', this)" $ "Linechart" + button ! class_ "tablink button-black" ! onclick "changeTab('heapchart', this)" $ "Heap" when (isJust cc_descs) $ do button ! class_ "tablink button-black" ! onclick "changeTab('cost-centres', this)" $ "Cost Centres" when (isJust closure_descs) $ do button ! class_ "tablink button-black" ! onclick "changeTab('closures', this)" $ "Detailed" - let itd = if noTraces as then NoTraceData else TraceData H.div ! class_ "row" $ do H.div ! class_ "column" $ do + let itd = if (noTraces as) then NoTraceData else TraceData mapM_ (\(vid, chartname, conf) -> H.div ! A.id chartname ! class_ "tabviz" $ do - renderChart itd True vid + renderChart itd conf True vid (TL.toStrict (encodeToLazyText (vegaJson (htmlConf as conf))))) [(1, "areachart", AreaChart Stacked) ,(2, "normalizedchart", AreaChart Normalized) ,(3, "streamgraph", AreaChart StreamGraph) - ,(4, "linechart", LineChart)] + ,(4, "linechart", LineChart) + ,(5, "heapchart", HeapChart) ] when (isJust cc_descs) $ do H.div ! A.id "cost-centres" ! class_ "tabviz" $ do - renderChart itd False 5 treevega + renderChart itd LineChart False 6 treevega forM_ closure_descs $ \v -> do H.div ! A.id "closures" ! class_ "tabviz" $ do v script $ preEscapedToHtml tablogic +select_data :: IncludeTraceData -> ChartType -> [Text] +select_data itd c = + case c of + AreaChart {} -> prof_data + LineChart {} -> prof_data + HeapChart {} -> ["heap"] ++ ["traces" | TraceData <- [itd]] + where + prof_data = ["samples"] ++ ["traces" | TraceData <- [itd]] + + htmlConf :: Args -> ChartType -> ChartConfig -htmlConf as ct = ChartConfig 1200 1000 (not (noTraces as)) (userColourScheme as) ct (fromIntegral <$> (fixedYAxis as)) +htmlConf as ct = ChartConfig 1200 1000 (not (noTraces as)) (userColourScheme as) "set1" ct (fromIntegral <$> (fixedYAxis as)) -renderChart :: IncludeTraceData -> Bool -> VizID -> Text -> Html -renderChart itd vega_lite vid vegaSpec = do +renderChart :: IncludeTraceData -> ChartType -> Bool -> VizID -> Text -> Html +renderChart itd ct vega_lite vid vegaSpec = do + let fields = select_data itd ct H.div ! A.id (fromString $ "vis" ++ show vid) ! class_ "chart" $ "" script ! type_ "text/javascript" $ do if vega_lite - then encloseScript itd vid vegaSpec - else encloseRawVegaScript itd vid vegaSpec + then encloseScript fields vid vegaSpec + else encloseRawVegaScript vid vegaSpec -renderChartWithJson :: IncludeTraceData -> Int -> Value -> Text -> Html -renderChartWithJson itd k dat vegaSpec = do +renderChartWithJson :: IncludeTraceData -> ChartType -> Int -> Value -> Text -> Html +renderChartWithJson itd ct k dat vegaSpec = do script $ insertJsonData dat - renderChart itd True k vegaSpec + renderChart itd ct True k vegaSpec templateString :: Header -> Value -> Maybe Value -> Maybe Html -> Args -> String @@ -201,4 +215,4 @@ ppHeapProfileType (HeapProfBreakdownRetainer) = "Retainer profiling (implied by -hr)" ppHeapProfileType (HeapProfBreakdownBiography) = "Biographical profiling (implied by -hb)" ppHeapProfileType (HeapProfBreakdownClosureType) = "Basic heap profile (implied by -hT)" ---ppHeapProfileType (HeapProfBreakdownInfoTable) = "Info table profile (implied by -hi)" +ppHeapProfileType (HeapProfBreakdownInfoTable) = "Info table profile (implied by -hi)" diff --git a/src/Eventlog/Types.hs b/src/Eventlog/Types.hs --- a/src/Eventlog/Types.hs +++ b/src/Eventlog/Types.hs @@ -45,16 +45,24 @@ data Sample = Sample Bucket Double deriving Show +data HeapSample = HeapSample Double Word64 deriving Show + data Frame = Frame Double [Sample] deriving Show -- | A trace we also want to show on the graph data Trace = Trace Double Text deriving Show +data HeapInfo = HeapInfo { heapSizeSamples :: [HeapSample] + , blocksSizeSamples :: [HeapSample] + , liveBytesSamples :: [HeapSample] + } deriving Show + data ProfData = ProfData { profHeader :: Header , profTotals :: (Map Bucket BucketInfo) , profCCMap :: Map Word32 CostCentre , profFrames :: [Frame] , profTraces :: [Trace] + , profHeap :: HeapInfo , profItl :: Map InfoTablePtr InfoTableLoc } deriving Show data InfoTableLoc = InfoTableLoc { itlName :: !Text diff --git a/src/Eventlog/Vega.hs b/src/Eventlog/Vega.hs --- a/src/Eventlog/Vega.hs +++ b/src/Eventlog/Vega.hs @@ -2,7 +2,9 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -module Eventlog.Vega (bandsToVega, tracesToVega) where +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} +module Eventlog.Vega (bandsToVega, tracesToVega, heapToVega) where import Data.Array.Base ((!), bounds) import Data.Array.Unboxed (UArray) @@ -12,6 +14,7 @@ import Eventlog.Types import Data.Aeson hiding (Series) import GHC.Generics +import Data.Word data VegaEntry = VegaEntry { x :: Double, y :: Double, k :: Int, c :: Text } deriving (Show, ToJSON, Generic) @@ -38,4 +41,13 @@ tracesToVega :: [Trace] -> [VegaTrace] tracesToVega = map (\(Trace t d) -> VegaTrace t d) + +data VegaHeap = VegaHeap { x :: Double, y :: Word64, c :: Text, k :: Int} + deriving (Show, ToJSON, Generic) + +heapToVega :: HeapInfo -> [VegaHeap] +heapToVega HeapInfo{..} = mk 2 "Heap Size" heapSizeSamples ++ mk 0 "Live Bytes" liveBytesSamples ++ mk 1 "Blocks Size" blocksSizeSamples + + where + mk k l xs = [VegaHeap t v l k | HeapSample t v <- xs] diff --git a/src/Eventlog/VegaTemplate.hs b/src/Eventlog/VegaTemplate.hs --- a/src/Eventlog/VegaTemplate.hs +++ b/src/Eventlog/VegaTemplate.hs @@ -24,6 +24,7 @@ data ChartType = AreaChart AreaChartType | LineChart + | HeapChart -- Arguments for directly outputting javascript data ChartConfig = @@ -31,6 +32,7 @@ , cheight :: Double , traces :: Bool , colourScheme :: Text + , lineColourScheme :: Text , chartType :: ChartType , fixedYAxisExtent :: Maybe Double } @@ -38,6 +40,9 @@ colourProperty :: ChartConfig -> ScaleProperty colourProperty c = SScheme (colourScheme c) [] +lineColourProperty :: ChartConfig -> ScaleProperty +lineColourProperty c = SScheme (lineColourScheme c) [] + ----------------------------------------------------------------------------------- -- The visualization consists of: -- - AreaChart (on the left top) @@ -64,6 +69,7 @@ description "Heap Profile", case chartType conf of LineChart -> lineChartFull c' + HeapChart -> heapChartFull c' AreaChart ct -> areaChartFull ct c' ] @@ -73,6 +79,9 @@ lineChartFull :: ChartConfig -> (VLProperty, VLSpec) lineChartFull c = vConcat [lineChart c, selectionChart c] +heapChartFull :: ChartConfig -> (VLProperty, VLSpec) +heapChartFull c = vConcat [heapChart c, selectionHeapChart c] + config :: [ConfigureSpec] -> (VLProperty, VLSpec) config = configure @@ -115,9 +124,47 @@ . filter (FSelection "legend") ----------------------------------------------------------------------------------- +-- The Heap Chart +----------------------------------------------------------------------------------- + +heapChart :: ChartConfig -> VLSpec +heapChart c = asSpec [layer ([heapLayer c] ++ [tracesLayer | traces c])] + +heapLayer :: ChartConfig -> VLSpec +heapLayer c = asSpec + [ + VL.width (0.9 * cwidth c), + VL.height (0.7 * cheight c), + dataFromSource "data_json_heap" [], + VL.mark Line [MPoint (PMMarker [])], + encodingHeapLayer c [], + transformHeapLayer [], + selectionRight [] + ] + +transformHeapLayer :: [TransformSpec] -> (VLProperty, VLSpec) +transformHeapLayer = + transform + . filter (FSelection "legend") + + +encodingHeapLayer :: ChartConfig -> [EncodingSpec] -> (VLProperty, VLSpec) +encodingHeapLayer c + = encoding + . color [MName "c", MmType Nominal, MScale [lineColourProperty c] + , MLegend [LNoTitle]] + . position X [PName "x", PmType Quantitative, PAxis [AxTitle ""] + ,PScale [SDomainOpt (DSelection "brush")]] + . position Y [PName "y", PmType Quantitative + , PAxis [AxTitle "Allocation", AxFormat "s"] + , PSort [ByFieldOp "k" Max]] + . tooltip [TName "y", TmType Quantitative, TFormat "s" ] + +----------------------------------------------------------------------------------- -- The Selection Chart ----------------------------------------------------------------------------------- + encodingSelection :: ChartConfig -> [EncodingSpec] -> (VLProperty, VLSpec) encodingSelection c = encoding @@ -141,6 +188,30 @@ dataFromSource "data_json_samples" [], VL.mark Area [], encodingSelection c [], + brush [] + ] + +----------------------------------------------------------------------------------- +-- The Heap Selection Chart +----------------------------------------------------------------------------------- + +encodingHeapSelection :: ChartConfig -> [EncodingSpec] -> (VLProperty, VLSpec) +encodingHeapSelection c = + encoding + . tooltip [] + . color [MName "c", MmType Nominal, MScale [lineColourProperty c], MLegend [LValues (LStrings ["Heap Size", "Blocks Size", "Live Bytes"])]] + . position X [PName "x", PmType Quantitative, PAxis [AxTitle "Time (s)"]] + . position Y [PName "y", PmType Quantitative, PAxis [], PSort [ByFieldOp "k" Max]] + +-- init field is not supported and necessary for dynamic loading + +selectionHeapChart :: ChartConfig -> VLSpec +selectionHeapChart c = asSpec [ + VL.width (0.9 * cwidth c), + VL.height (0.1 * cheight c), + dataFromSource "data_json_heap" [], + VL.mark Line [MPoint (PMMarker [])], + encodingHeapSelection c [], brush [] ]