diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,11 @@ +0.6, released 2019-10-22 + +* Revamp how cost centre profiles are displayed. +* Fix incorrectly calculated start time for certain profiles. +* Line chart now displays points for each sample so it's easier to see where to hover. +* Add `--y-axis` option to allow the user to specify the extent of the y-axis. + This is useful when comparing two different profiles together. + 0.5, released 2019-10-11 * Add some more metainformation to the header (sample mode and sample interval) diff --git a/eventlog2html.cabal b/eventlog2html.cabal --- a/eventlog2html.cabal +++ b/eventlog2html.cabal @@ -1,5 +1,5 @@ Name: eventlog2html -Version: 0.5.0 +Version: 0.6.0 Synopsis: Visualise an eventlog Description: eventlog2html is a library for visualising eventlogs. At the moment, the intended use is to visualise eventlogs @@ -26,6 +26,7 @@ javascript/vega@5.4.0 javascript/stylesheet.css javascript/tablogic.js + javascript/ccmap.vg javascript/milligram.min.css javascript/normalize.min.css cabal-version: 1.18 @@ -53,13 +54,15 @@ text >= 1.2.3 && < 1.3, time >= 1.8.0 && < 2.0, vector >= 0.11, - trie-simple >= 0.4 + trie-simple >= 0.4, + hashable >= 1.0 GHC-options: -Wall default-language: Haskell2010 HS-source-dirs: src exposed-modules: Eventlog.Args Eventlog.Data + Eventlog.Trie Eventlog.Javascript Eventlog.Types Eventlog.Total @@ -70,6 +73,7 @@ Eventlog.Vega Eventlog.HtmlTemplate Eventlog.VegaTemplate + other-modules: Paths_eventlog2html Executable eventlog2html GHC-options: -Wall diff --git a/javascript/ccmap.vg b/javascript/ccmap.vg new file mode 100644 --- /dev/null +++ b/javascript/ccmap.vg @@ -0,0 +1,102 @@ +{ + "$schema": "https://vega.github.io/schema/vega/v5.json", + "width": 1000, + "height": 600, + "padding": 5, + + "signals": [ + ], + + "data": [ + { + "name": "tree", + "values": desc_json, + "transform": [ + { + "type": "stratify", + "key": "id", + "parentKey": "parent" + }, + { + "type": "tree", + "method": "tidy", + "size": [{"signal": "width - 100"}, {"signal": "height"}], + "separation": false, + "as": ["x", "y", "depth", "children"] + } + ] + }, + { + "name": "links", + "source": "tree", + "transform": [ + { "type": "treelinks" }, + { + "type": "linkpath", + "orient": "vertical", + "shape": "diagonal" + } + ] + } + ], + + "scales": [ + { + "name": "color", + "type": "ordinal", + "domain": { "fields": [{"data": "tree", "field": "c"} + ,{"data": "tree", "field": "c"}], "sort": true}, + "range": {"scheme": colour_scheme} + } + ], + + "marks": [ + { + "type": "path", + "from": {"data": "links"}, + "encode": { + "update": { + "path": {"field": "path"}, + "stroke": {"value": "#ccc"} + } + } + }, + { + "type": "symbol", + "from": {"data": "tree"}, + "encode": { + "enter": { + "size": {"value": 500}, + "stroke": {"value": "black"}, + "tooltip": {"signal": "datum.name"} + }, + "update": { + "x": {"field": "x"}, + "y": {"field": "y"}, + "fill": {"scale": "color", "field": "c"} + } + } + }, + { + "type": "text", + "from": {"data": "tree"}, + "encode": { + "enter": { + "text": {"field": "ccs"}, + "fontSize": {"value": 9}, + "baseline": {"value": "middle"} + }, + "update": { + "x": {"field": "x"}, + "y": {"field": "y"}, + "angle": {"signal": "datum.children ? 0 : 0"}, + "dy": {"signal": "datum.children ? 0 : 0"}, + "dx": {"signal": "datum.children ? 0 : 0"}, + "align": {"signal": "datum.children ? 'center' : 'center'"}, + "opacity": 0 + } + } + } + ] +} + diff --git a/javascript/stylesheet.css b/javascript/stylesheet.css --- a/javascript/stylesheet.css +++ b/javascript/stylesheet.css @@ -21,3 +21,13 @@ vertical-align: baseline; background: transparent; } + +.hoverflow { + overflow: auto; + width: 900px; + white-space: nowrap; +} + +#description{ + visibility: hidden; +} diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -19,6 +19,7 @@ when (null (files a)) exitSuccess argsToOutput a + argsToOutput :: Args -> IO () argsToOutput a@Args{files = files', outputFile = Nothing} = if | json a -> forM_ files' $ \file -> doOneJson a file (file <.> "json") @@ -31,17 +32,17 @@ doOneJson :: Args -> FilePath -> FilePath -> IO () doOneJson a fin fout = do - (_, val) <- generateJson fin a + (_, val, _) <- generateJson fin a encodeFile fout val doOneHtml :: Args -> FilePath -> FilePath -> IO () doOneHtml a fin fout = do - (header, data_json) <- generateJsonValidate checkTraces fin a - let html = templateString header data_json a + (header, data_json, descs) <- generateJsonValidate checkTraces fin a + let html = templateString header data_json descs a 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/Args.hs b/src/Eventlog/Args.hs --- a/src/Eventlog/Args.hs +++ b/src/Eventlog/Args.hs @@ -26,6 +26,7 @@ , traceEvents :: Bool -- ^ By default, only traceMarkers are included. -- This option enables the inclusion of traceEvents. , userColourScheme :: Text + , fixedYAxis :: Maybe Int , includeStr :: [Text] , excludeStr :: [Text] , outputFile :: Maybe String @@ -72,6 +73,10 @@ ( 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\". ") + <*> option (Just <$> auto) + ( long "y-axis" + <> value Nothing + <> help "Fixed value for the maximum extent of the y-axis in bytes. This option is useful for comparing profiles together.") <*> many (option str (short 'i' <> long "include" diff --git a/src/Eventlog/Bands.hs b/src/Eventlog/Bands.hs --- a/src/Eventlog/Bands.hs +++ b/src/Eventlog/Bands.hs @@ -11,14 +11,13 @@ import Data.Array.Unboxed (UArray) import Data.Map (Map, lookup, size, foldrWithKey) import Prelude hiding (lookup, lines, words, length) -import Data.Text (Text) import Eventlog.Types import Data.HashTable.ST.Basic hiding (lookup) import Data.Aeson hiding (Series) import GHC.Generics import Data.Set (Set, notMember) -bands :: Header -> Map Text Int -> [Frame] -> (UArray Int Double, UArray (Int, Int) Double) +bands :: Header -> Map Bucket Int -> [Frame] -> (UArray Int Double, UArray (Int, Int) Double) bands h bs frames = runST $ do times <- newArray (1, hCount h) 0 vals <- newArray ((-1,1), (size bs, hCount h)) 0 @@ -32,7 +31,7 @@ vals' <- unsafeFreezeSTUArray vals return (times', vals') -bandsToSeries :: Map Text Int -> (UArray Int Double, UArray (Int, Int) Double) +bandsToSeries :: Map Bucket Int -> (UArray Int Double, UArray (Int, Int) Double) -> [Series] bandsToSeries ks (ts, vs) = let (t1, tn) = bounds ts @@ -40,12 +39,12 @@ where go_1 :: [(Double, Double)] go_1 = flip map [t1 .. tn] $ \t -> (ts ! t, vs ! (v, t)) - in foldrWithKey go (go "OTHER" 0 []) ks + in foldrWithKey go (go (Bucket "OTHER") 0 []) ks -data Series = Series { key :: Text, values :: [(Double, Double)] } +data Series = Series { key :: Bucket, values :: [(Double, Double)] } deriving (Show, ToJSON, Generic) -series :: Set Text -> [Frame] -> [Series] +series :: Set Bucket -> [Frame] -> [Series] series ks fs = runST $ do m <- new forM_ (reverse fs) $ \(Frame t s) -> diff --git a/src/Eventlog/Data.hs b/src/Eventlog/Data.hs --- a/src/Eventlog/Data.hs +++ b/src/Eventlog/Data.hs @@ -3,6 +3,7 @@ import Prelude hiding (readFile) import Data.Aeson (Value(..), (.=), object) +import qualified Data.Map as Map import Eventlog.Args (Args(..)) import Eventlog.Bands (bands) @@ -10,20 +11,29 @@ import qualified Eventlog.HeapProf as H import Eventlog.Prune (prune) import Eventlog.Vega -import Eventlog.Types (Header, ProfData(..)) +import Eventlog.Types (Header(..), ProfData(..), HeapProfBreakdown(..)) +import Data.List +import Data.Ord +import Eventlog.Trie -generateJsonValidate :: (ProfData -> IO ()) -> FilePath -> Args -> IO (Header, Value) +generateJsonValidate :: (ProfData -> IO ()) -> FilePath -> Args -> IO (Header, Value, Maybe 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 + dat@(ProfData h binfo ccMap fs traces) <- chunk file validate dat - let keeps = prune a totals + let keeps = prune a binfo combinedJson = object [ - "samples" .= bandsToVega keeps (bands h keeps fs) + "samples" .= bandsToVega keeps (bands h (Map.map fst keeps) fs) , "traces" .= tracesToVega traces ] - return (h, combinedJson) + mdescs = + sortBy (flip (comparing (fst . snd))) $ Map.toList keeps + -- Only supply the cost centre view in cost centre profiling mode. + descs = case hHeapProfileType h of + Just HeapProfBreakdownCostCentre -> Just (outputTree ccMap mdescs) + _ -> Nothing + return (h, combinedJson, descs) -generateJson :: FilePath -> Args -> IO (Header, Value) +generateJson :: FilePath -> Args -> IO (Header, Value, Maybe 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 @@ -29,6 +29,8 @@ import Data.Char import System.IO import qualified Data.Trie.Map as Trie +import Data.Map.Merge.Lazy +import Data.Functor.Identity type PartialHeader = Int -> Header @@ -38,10 +40,21 @@ chunk :: Args -> FilePath -> IO ProfData chunk a f = do (EventLog _ e) <- either error id <$> readEventLogFromFile f - (ph, frames, traces) <- eventsToHP a e + (ph, bucket_map, ccMap, frames, traces) <- eventsToHP a e let (counts, totals) = total frames - return $ (ProfData (ph counts) totals frames traces) + -- If both keys are present, combine + combine = zipWithAMatched (\_ (t, mt) (tot, sd) -> Identity $ BucketInfo t mt tot sd) + -- If total is missing, something bad has happened + combineMissingTotal :: Bucket -> (Text, Maybe [Word32]) -> Identity BucketInfo + combineMissingTotal k = error ("Missing total for: " ++ show k) + -- This case happens when we are not in CC mode + combineMissingDesc :: Bucket -> (Double, Double) -> Identity BucketInfo + combineMissingDesc (Bucket t) (tot, sd) = Identity (BucketInfo t Nothing tot sd) + + binfo = merge (traverseMissing combineMissingTotal) (traverseMissing combineMissingDesc) combine bucket_map totals + return $ (ProfData (ph counts) binfo ccMap frames traces) + checkGHCVersion :: EL -> Maybe String checkGHCVersion EL { ident = Just (version,_)} | version <= makeVersion [8,4,4] = @@ -57,19 +70,19 @@ ++ ", which does not support biographical or retainer profiling." checkGHCVersion _ = Nothing - -eventsToHP :: Args -> Data -> IO (PartialHeader, [Frame], [Trace]) +eventsToHP :: Args -> Data -> IO (PartialHeader, BucketMap, Map.Map Word32 CostCentre, [Frame], [Trace]) eventsToHP a (Data es) = do let 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) + return $ (elHeader el, elBucketMap el, ccMap, fir : reverse (las: normalise frames) , traces) normalise :: [FrameEL] -> [Frame] normalise fs = map (\(FrameEL t ss) -> Frame (fromNano t) ss) fs +type BucketMap = Map.Map Bucket (Text, Maybe [Word32]) data EL = EL { pargs :: !(Maybe [String]) @@ -77,6 +90,9 @@ , samplingRate :: !(Maybe Word64) , heapProfileType :: !(Maybe HeapProfBreakdown) , ccMap :: !(Map.Map Word32 CostCentre) + -- At the moment bucketMap and CCS map are quite similar, cost centre profiling + -- is the only mode to populate the bucket map + , bucketMap :: BucketMap , ccsMap :: CCSMap , clocktimeSec :: !Word64 , samples :: !(Maybe FrameEL) @@ -89,29 +105,32 @@ data CCSMap = CCSMap (Trie.TMap Word32 CCStack) Int deriving Show + data CCStack = CCStack { ccsId :: Int, ccsName :: Text } deriving Show getCCSId :: EL -> Vector Word32 -> (CCStack, EL) getCCSId el@EL { ccsMap = (CCSMap trie uniq), ccMap = ccMap } k = - let kl = toList k + let kl = reverse $ toList k in case Trie.lookup kl trie of Just n -> (n, el) Nothing -> let new_stack = CCStack uniq name - in (new_stack, el { ccsMap = CCSMap (Trie.insert kl new_stack trie) (uniq + 1) }) + + sid = T.pack $ "(" ++ show uniq ++ ") " + short_bucket_info = sid <> name + bucket_info = (short_bucket_info, Just kl) + bucket_key = Bucket (T.pack (show uniq)) + in (new_stack, el { ccsMap = CCSMap (Trie.insert kl new_stack trie) (uniq + 1) + , bucketMap = Map.insert bucket_key bucket_info (bucketMap el) }) where name = fromMaybe "MAIN" $ do cid <- (k !? 0) - CC{label, modul} <- Map.lookup cid ccMap - return $ modul <> "." <> label + CC{label} <- Map.lookup cid ccMap + return $ label -data CostCentre = CC { cid :: Word32 - , label :: Text - , modul :: Text - , loc :: Text } deriving Show -initEL :: Word64 -> EL -initEL t = EL +initEL :: EL +initEL = EL { pargs = Nothing , ident = Nothing , samplingRate = Nothing @@ -120,17 +139,17 @@ , samples = Nothing , frames = [] , traces = [] - , start = t + , start = 0 , end = 0 , ccMap = Map.empty , ccsMap = CCSMap Trie.empty 0 + , bucketMap = Map.empty } foldEvents :: Args -> [Event] -> EL -foldEvents a (e:es) = - let res = foldl' (folder a) (initEL (evTime e)) (e:es) +foldEvents a es = + let res = foldl' (folder a) initEL es in addFrame 0 res -foldEvents _ [] = error "Empty event log" folder :: Args -> EL -> Event -> EL folder a el (Event t e _) = el & @@ -153,7 +172,7 @@ HeapProfSampleBegin {} -> addFrame t HeapBioProfSampleBegin { heapProfSampleTime = t' } -> addFrame t' HeapProfSampleCostCentre _hid r d s -> addCCSample r d s - HeapProfSampleString _hid res k -> addSample (Sample k (fromIntegral res)) + HeapProfSampleString _hid res k -> addSample (Sample (Bucket k) (fromIntegral res)) _ -> id @@ -174,16 +193,15 @@ 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 = - let (CCStack stack_id tid, el') = getCCSId el st + let (CCStack stack_id _tid, el') = getCCSId el st -- TODO: Can do better than this by differentiating normal samples form stack samples - sample_string = (T.pack $ "(" ++ show stack_id ++ ") ") <> tid - in addSample (Sample sample_string (fromIntegral res)) el' + sample_string = T.pack (show stack_id) + in addSample (Sample (Bucket sample_string) (fromIntegral res)) el' addClocktime :: Word64 -> EL -> EL @@ -250,16 +268,11 @@ elHeader EL{..} = let title = maybe "" (T.unwords . map T.pack) pargs date = formatDate clocktimeSec - profileType = ppHeapProfileType heapProfileType ppSamplingRate = T.pack . maybe "" (show . fromNano) $ samplingRate - in Header title date profileType ppSamplingRate "" "" + in Header title date heapProfileType ppSamplingRate "" "" -ppHeapProfileType :: Maybe HeapProfBreakdown -> Text -ppHeapProfileType (Just HeapProfBreakdownCostCentre) = "Cost centre profiling (implied by -hc)" -ppHeapProfileType (Just HeapProfBreakdownModule) = "Profiling by module (implied by -hm)" -ppHeapProfileType (Just HeapProfBreakdownClosureDescr) = "Profiling by closure description (implied by -hd)" -ppHeapProfileType (Just HeapProfBreakdownTypeDescr) = "Profiling by type (implied by -hy)" -ppHeapProfileType (Just HeapProfBreakdownRetainer) = "Retainer profiling (implied by -hr)" -ppHeapProfileType (Just HeapProfBreakdownBiography) = "Biographical profiling (implied by -hb)" -ppHeapProfileType (Just HeapProfBreakdownClosureType) = "Basic heap profile (implied by -hT)" -ppHeapProfileType Nothing = "" + +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 @@ -5,6 +5,7 @@ import Data.Text (Text, lines, init, drop, length, isPrefixOf, unpack, words, pack) import Data.Text.IO (readFile) import Data.Attoparsec.Text (parseOnly, double) +import qualified Data.Map as Map import Eventlog.Total import Eventlog.Types @@ -13,8 +14,10 @@ chunk f = do (ph, fs) <- chunkT <$> readFile f let (counts, totals) = total fs + -- Heap profiles don't contain any other information than the simple bucket name + binfo = Map.mapWithKey (\(Bucket k) (t,s) -> BucketInfo k Nothing t s ) totals -- Heap profiles do not support traces - return (ProfData (ph counts) totals fs []) + return (ProfData (ph counts) binfo mempty fs []) chunkT :: Text -> (Int -> Header, [Frame]) chunkT s = @@ -24,7 +27,7 @@ zipWith header [sJOB, sDATE, sSAMPLE_UNIT, sVALUE_UNIT] hs fs = chunkSamples ss in ( - Header job date (pack "") (pack "") smpU valU + Header job date Nothing (pack "") smpU valU , fs ) @@ -54,7 +57,7 @@ parseSample s = let [k,vs] = words s !v = readDouble vs - in (Sample k v) + in (Sample (Bucket k) v) sampleTime :: Text -> Text -> Double diff --git a/src/Eventlog/HtmlTemplate.hs b/src/Eventlog/HtmlTemplate.hs --- a/src/Eventlog/HtmlTemplate.hs +++ b/src/Eventlog/HtmlTemplate.hs @@ -15,8 +15,12 @@ import Eventlog.Javascript import Eventlog.Args -import Eventlog.Types (Header(..)) +import Eventlog.Types (Header(..), HeapProfBreakdown(..)) import Eventlog.VegaTemplate +import Paths_eventlog2html +import Data.Version +import Control.Monad +import Data.Maybe type VizID = Int @@ -27,26 +31,53 @@ where dat' = TL.toStrict (T.decodeUtf8 (encode dat)) +insertJsonDesc :: Value -> Html +insertJsonDesc dat = preEscapedToHtml $ T.unlines [ + "desc_json= " `append` dat' `append` ";" + , "console.log(desc_json);" ] + where + dat' = TL.toStrict (T.decodeUtf8 (encode dat)) +-- Dynamically bound in ccs tree +insertColourScheme :: Text -> Html +insertColourScheme scheme = preEscapedToHtml $ T.unlines [ + "colour_scheme= \"" `append` scheme `append` "\";" + , "console.log(colour_scheme);" ] + +data_sets :: [Text] +data_sets = [ + ".insert(\"data_json_samples\", data_json.samples)" + , ".insert(\"data_json_traces\", data_json.traces)" ] + encloseScript :: VizID -> Text -> Html -encloseScript vid vegaspec = preEscapedToHtml $ T.unlines [ +encloseScript = encloseScriptX True + +encloseRawVegaScript :: VizID -> Text -> Html +encloseRawVegaScript = encloseScriptX False + +encloseScriptX :: Bool -> 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) => " - , "res.view" - , ".insert(\"data_json_samples\", data_json.samples)" - , ".insert(\"data_json_traces\", data_json.traces)" - , ".runAsync());" ] + , "res.view" ] +-- 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 else []) ++ + [ ".runAsync());" ]) where vidt = T.pack $ show vid -htmlHeader :: Value -> Args -> Html -htmlHeader dat as = +htmlHeader :: Value -> Maybe Value -> Args -> Html +htmlHeader dat desc as = H.head $ do - H.title "Heap Profile" + H.title "eventlog2html - Heap Profile" meta ! charset "UTF-8" script $ insertJsonData dat + maybe (return ()) (script . insertJsonDesc) desc + script $ insertColourScheme (userColourScheme as) if not (noIncludejs as) then do script $ preEscapedToHtml vegaLite @@ -64,9 +95,11 @@ -- Include this last to overwrite some milligram styling H.style $ preEscapedToHtml stylesheet -template :: Header -> Value -> Args -> Html -template header' dat as = docTypeHtml $ do - htmlHeader dat as + +template :: Header -> Value -> Maybe Value -> Args -> Html +template header' dat descs as = docTypeHtml $ do + H.stringComment $ "Generated with eventlog2html-" <> showVersion version + htmlHeader dat descs as body $ H.div ! class_ "container" $ do H.div ! class_ "row" $ do H.div ! class_ "column" $ do @@ -82,10 +115,11 @@ "Created at: " code $ toHtml $ hDate header' - H.div ! class_ "row" $ do - H.div ! class_ "column" $ do - "Type of profile: " - code $ toHtml $ hHeapProfileType header' + forM_ (hHeapProfileType header') $ \prof_type -> do + H.div ! class_ "row" $ do + H.div ! class_ "column" $ do + "Type of profile: " + code $ toHtml $ ppHeapProfileType prof_type H.div ! class_ "row" $ do H.div ! class_ "column" $ do @@ -98,35 +132,52 @@ 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" + when (isJust descs) $ do + button ! class_ "tablink button-black" ! onclick "changeTab('cost-centres', this)" $ "Cost Centres" H.div ! class_ "row" $ do H.div ! class_ "column" $ do mapM_ (\(vid, chartname, conf) -> H.div ! A.id chartname ! class_ "tabviz" $ do - renderChart vid + renderChart True vid (TL.toStrict (encodeToLazyText (vegaJson (htmlConf as conf))))) [(1, "areachart", AreaChart Stacked) ,(2, "normalizedchart", AreaChart Normalized) ,(3, "streamgraph", AreaChart StreamGraph) ,(4, "linechart", LineChart)] + when (isJust descs) $ do + H.div ! A.id "cost-centres" ! class_ "tabviz" $ do + renderChart False 5 treevega script $ preEscapedToHtml tablogic + htmlConf :: Args -> ChartType -> ChartConfig -htmlConf as = ChartConfig 1200 1000 (not (noTraces as)) (userColourScheme as) +htmlConf as ct = ChartConfig 1200 1000 (not (noTraces as)) (userColourScheme as) ct (fromIntegral <$> (fixedYAxis as)) -renderChart :: VizID -> Text -> Html -renderChart vid vegaSpec = do +renderChart :: Bool -> VizID -> Text -> Html +renderChart vega_lite vid vegaSpec = do H.div ! A.id (fromString $ "vis" ++ show vid) ! class_ "chart" $ "" script ! type_ "text/javascript" $ do - (encloseScript vid vegaSpec) + if vega_lite + then encloseScript vid vegaSpec + else encloseRawVegaScript vid vegaSpec renderChartWithJson :: Int -> Value -> Text -> Html renderChartWithJson k dat vegaSpec = do script $ insertJsonData dat - renderChart k vegaSpec + renderChart True k vegaSpec -templateString :: Header -> Value -> Args -> String -templateString header' dat as = - renderHtml $ template header' dat as +templateString :: Header -> Value -> Maybe Value -> Args -> String +templateString header' dat descs as = + renderHtml $ template header' dat descs as + +ppHeapProfileType :: HeapProfBreakdown -> Text +ppHeapProfileType (HeapProfBreakdownCostCentre) = "Cost centre profiling (implied by -hc)" +ppHeapProfileType (HeapProfBreakdownModule) = "Profiling by module (implied by -hm)" +ppHeapProfileType (HeapProfBreakdownClosureDescr) = "Profiling by closure description (implied by -hd)" +ppHeapProfileType (HeapProfBreakdownTypeDescr) = "Profiling by type (implied by -hy)" +ppHeapProfileType (HeapProfBreakdownRetainer) = "Retainer profiling (implied by -hr)" +ppHeapProfileType (HeapProfBreakdownBiography) = "Biographical profiling (implied by -hb)" +ppHeapProfileType (HeapProfBreakdownClosureType) = "Basic heap profile (implied by -hT)" diff --git a/src/Eventlog/Javascript.hs b/src/Eventlog/Javascript.hs --- a/src/Eventlog/Javascript.hs +++ b/src/Eventlog/Javascript.hs @@ -8,6 +8,7 @@ , tablogic , milligram , normalizecss + , treevega ) where import Data.Text @@ -34,4 +35,7 @@ normalizecss :: Text normalizecss = decodeUtf8 $(embedFile "javascript/normalize.min.css") + +treevega :: Text +treevega = decodeUtf8 $(embedFile "javascript/ccmap.vg") diff --git a/src/Eventlog/Prune.hs b/src/Eventlog/Prune.hs --- a/src/Eventlog/Prune.hs +++ b/src/Eventlog/Prune.hs @@ -2,16 +2,16 @@ ( prune ) where -import Data.Text (Text) import Data.List (sortBy) import Data.Ord (comparing) -import Data.Map.Strict (Map, toList, fromList) +import Data.Map.Strict (Map, toList, fromList, (!)) +import Eventlog.Types import Eventlog.Args (Args(..), Sort(..)) type Compare a = a -> a -> Ordering -getComparison :: Args -> Compare (Text, (Double, Double)) +getComparison :: Args -> Compare (Bucket, BucketInfo) getComparison Args { sorting = Size, reversing = False } = cmpSizeDescending getComparison Args { sorting = Size, reversing = True } = cmpSizeAscending getComparison Args { sorting = StdDev, reversing = False } = cmpStdDevDescending @@ -21,26 +21,28 @@ cmpNameAscending, cmpNameDescending, cmpStdDevAscending, cmpStdDevDescending, - cmpSizeAscending, cmpSizeDescending :: Compare (Text, (Double, Double)) + cmpSizeAscending, cmpSizeDescending :: Compare (Bucket, BucketInfo) cmpNameAscending = comparing fst cmpNameDescending = flip cmpNameAscending -cmpStdDevAscending = comparing (snd . snd) +cmpStdDevAscending = comparing (bucketStddev . snd) cmpStdDevDescending = flip cmpStdDevAscending -cmpSizeAscending = comparing (fst . snd) +cmpSizeAscending = comparing (bucketTotal . snd) cmpSizeDescending = flip cmpSizeAscending -prune :: Args -> Map Text (Double, Double) -> Map Text Int +prune :: Args -> Map Bucket BucketInfo + -> Map Bucket (Int, BucketInfo) prune args ts = let ccTotals = sortBy cmpSizeDescending (toList ts) - sizes = map (fst . snd) ccTotals + sizes = map (bucketTotal . snd) ccTotals limit = sum sizes bigs = takeWhile (< limit) . scanl (+) 0 $ sizes bands = zipWith const ccTotals $ take (bound $ nBands args) bigs ccs = map fst (sortBy (getComparison args) bands) - in fromList (reverse ccs `zip` [1 ..]) + res :: [(Bucket, (Int, BucketInfo))] + res = zipWith (\b k -> (b, (k, ts ! b))) (reverse ccs) [1..] + in fromList res 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 @@ -4,21 +4,20 @@ import Control.Monad.State.Strict (State(), execState, get, put, modify) import Data.Map (Map, empty, alter) import Prelude hiding (init, lookup, lines, words, drop, length, readFile) -import Data.Text (Text) import Eventlog.Types data Parse = Parse - { totals :: !(Map Text (Double, Double)) -- compute running totass and total of squares + { totals :: !(Map Bucket (Double, Double)) -- compute running totals and total of squares , count :: !Int -- number of frames } parse0 :: Parse parse0 = Parse{ totals = empty, count = 0 } -total :: [Frame] -> (Int, Map Text (Double, Double)) +total :: [Frame] -> (Int, Map Bucket (Double, Double)) total fs = let parse1 = flip execState parse0 . mapM_ parseFrame $ fs in ( diff --git a/src/Eventlog/Trie.hs b/src/Eventlog/Trie.hs new file mode 100644 --- /dev/null +++ b/src/Eventlog/Trie.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} +module Eventlog.Trie where + +import Prelude hiding (init, lookup) +import Data.Text (Text) + +import Eventlog.Types +import Data.Word +import qualified Data.Map as Map +import Data.Map ((!)) +import qualified Data.Trie.Map as Trie +import qualified Data.Trie.Map.Internal as TrieI +import Data.Aeson + +outputTree :: Map.Map Word32 CostCentre -> [(Bucket, (Int, BucketInfo))] + -> Value +outputTree ccMap mdescs = + let t = Trie.fromList [(k, (i, b, v)) | (Bucket b, (i, BucketInfo v (Just k) _ _)) <- mdescs ] + in toJSON $ outputTrie ccMap t + +outputTrie :: Map.Map Word32 CostCentre -> Trie.TMap Word32 (Int, Text, Text) -> [Value] +outputTrie ccMap (TrieI.TMap (TrieI.Node ni m)) = + (mkNode 0 Nothing "MAIN" ni) : outputTrieLoop ccMap 0 m + + +outputTrieLoop :: Map.Map Word32 CostCentre + -> Word32 + -> Map.Map Word32 (Trie.TMap Word32 (Int, Text, Text)) + -> [Value] +outputTrieLoop ccMap p cs = + let go p' (TrieI.TMap (TrieI.Node mv cs')) os + = mkNode p' (Just p) (label $ ccMap ! p') mv : outputTrieLoop ccMap p' cs' ++ os + in Map.foldrWithKey go [] cs + +mkNode :: Word32 -> Maybe Word32 -> Text -> Maybe (Int, Text, Text) -> Value +mkNode i mparent n mccs = object $ [ "id" .= i, "name" .= n + , "ccs" .= maybe "" (\(_, v, _) -> v) mccs + , "c" .= maybe "OTHER" (\(_, _, c) -> c) mccs] + ++ ["parent" .= p | Just p <- [mparent] ] + + + diff --git a/src/Eventlog/Types.hs b/src/Eventlog/Types.hs --- a/src/Eventlog/Types.hs +++ b/src/Eventlog/Types.hs @@ -1,24 +1,52 @@ -module Eventlog.Types where +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Eventlog.Types(module Eventlog.Types, HeapProfBreakdown(..)) where import Data.Text (Text) import Data.Map (Map) +import Data.Aeson +import Data.Hashable +import Data.Word +import GHC.RTS.Events (HeapProfBreakdown(..)) data Header = Header { hJob :: Text , hDate :: Text - , hHeapProfileType :: Text + , hHeapProfileType :: Maybe HeapProfBreakdown , hSamplingRate :: Text , hSampleUnit :: Text , hValueUnit :: Text , hCount :: Int } deriving Show -data Sample = Sample Text Double deriving Show +-- The bucket is a key to uniquely identify a band +newtype Bucket = Bucket Text + deriving (Show, Ord, Eq) + deriving newtype (ToJSON, Hashable) + + +data BucketInfo = BucketInfo { shortDescription :: Text -- For the legend and hover + , longDescription :: Maybe [Word32] + , bucketTotal :: Double + , bucketStddev :: Double + } deriving Show + +data CostCentre = CC { cid :: Word32 + , label :: Text + , modul :: Text + , loc :: Text } deriving Show + +data Sample = Sample Bucket Double 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 ProfData = ProfData Header (Map Text (Double, Double)) [Frame] [Trace] deriving Show +data ProfData = ProfData { profHeader :: Header + , profTotals :: (Map Bucket BucketInfo) + , profCCMap :: Map Word32 CostCentre + , profFrames :: [Frame] + , profTraces :: [Trace] } deriving Show diff --git a/src/Eventlog/Vega.hs b/src/Eventlog/Vega.hs --- a/src/Eventlog/Vega.hs +++ b/src/Eventlog/Vega.hs @@ -6,7 +6,7 @@ import Data.Array.Base ((!), bounds) import Data.Array.Unboxed (UArray) -import Data.Map (Map, foldrWithKey) +import Data.Map (Map, foldr) import Prelude hiding (lookup, lines, words, length) import Data.Text (Text) import Eventlog.Types @@ -16,16 +16,22 @@ data VegaEntry = VegaEntry { x :: Double, y :: Double, k :: Int, c :: Text } deriving (Show, ToJSON, Generic) -bandsToVega :: Map Text Int +bandsToVega :: Map Bucket (Int, BucketInfo) -> (UArray Int Double, UArray (Int, Int) Double) -> [VegaEntry] bandsToVega ks (ts, vs) = let (t1, tn) = bounds ts - go key v rs = go_1 ++ rs + go (i, binfo) rs = go_1 ++ rs where + txt = shortDescription binfo + go_1 :: [VegaEntry] - go_1 = flip map [t1 .. tn] $ \t -> VegaEntry (ts ! t) (vs ! (v, t)) v key - in foldrWithKey go (go "OTHER" 0 []) ks + go_1 = flip map [t1 .. tn] $ \t -> VegaEntry (ts ! t) (vs ! (i, t)) i txt + + other_binfo = BucketInfo "OTHER" Nothing + -- Last two fields currently unused + 0 0 + in Data.Map.foldr go (go (0, other_binfo) []) ks data VegaTrace = VegaTrace { tx :: Double, desc :: Text } deriving (Show, ToJSON, Generic) diff --git a/src/Eventlog/VegaTemplate.hs b/src/Eventlog/VegaTemplate.hs --- a/src/Eventlog/VegaTemplate.hs +++ b/src/Eventlog/VegaTemplate.hs @@ -30,7 +30,6 @@ = AreaChart AreaChartType | LineChart - -- Arguments for directly outputting javascript data ChartConfig = ChartConfig { cwidth :: Double @@ -38,6 +37,7 @@ , traces :: Bool , colourScheme :: Text , chartType :: ChartType + , fixedYAxisExtent :: Maybe Double } colourProperty :: ChartConfig -> ScaleProperty @@ -104,7 +104,7 @@ VL.width (0.9 * cwidth c), VL.height (0.7 * cheight c), dataFromSource "data_json_samples" [], - VL.mark Line [], + VL.mark Line [MPoint (PMMarker [])], encodingLineLayer c [], transformLineLayer [] ] @@ -190,7 +190,7 @@ ] . position X [PName "x", PmType Quantitative, PAxis [AxTitle ""] , PScale [SDomain (DSelection "brush")]] - . position Y [PName "y" + . position Y ([PName "y" , PmType Quantitative , PAxis $ case ct of Stacked -> [AxTitle "Allocation" @@ -204,6 +204,8 @@ Stacked -> StZero Normalized -> StNormalize StreamGraph -> StCenter)] + ++ + [PScale [SDomain (DNumbers [0, extent])] | Just extent <- [fixedYAxisExtent c]] ) transformBandsLayer :: [LabelledSpec] -> (VLProperty, VLSpec) transformBandsLayer = @@ -251,7 +253,7 @@ . injectJSON "tooltip" Null . color [ - MSelectionCondition (SelectionName "legend") [MName "c", MmType Nominal, MAggregate Min, MLegend []] [MString "lightgray"] + MSelectionCondition (SelectionName "legend") [MName "c", MmType Nominal, MLegend []] [MString "lightgray"] ] . position Y [PName "c" , PmType Nominal