eventlog2html 0.2.0 → 0.3.0

raw patch · 8 files changed

+119/−59 lines, 8 filesdep +vectordep ~hvegaPVP ok

version bump matches the API change (PVP)

Dependencies added: vector

Dependency ranges changed: hvega

API changes (from Hackage documentation)

Files

• CHANGELOG +6/−0
• eventlog2html.cabal +4/−3
• src/Eventlog/Data.hs +1/−4
• src/Eventlog/Events.hs +84/−14
• src/Eventlog/HeapProf.hs +6/−3
• src/Eventlog/Total.hs +3/−3
• src/Eventlog/Types.hs +0/−2
• src/Eventlog/VegaTemplate.hs +15/−30

@@ -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

@@ -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

@@ -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)

@@ -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 }

@@ -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

@@ -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)       ) 

@@ -11,8 +11,6 @@   , hCount       :: Int   } -type PartialHeader = Int -> Header- data Sample = Sample Text Double deriving Show  data Frame = Frame Double [Sample] deriving Show

@@ -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 =