diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Revision history for hs-speedscope +## 0.3.0 -- 2025-06-07 +* Introduce Speedscope.Schema [#12](https://github.com/mpickering/hs-speedscope/pull/12) +* Allow more recent ghc-events [#13](https://github.com/mpickering/hs-speedscope/pull/13) +* Use CURRENT_PACKAGE_VERSION to get package version [#14](https://github.com/mpickering/hs-speedscope/pull/14) +* Use machines to decouple filtering and accumulation [#15](https://github.com/mpickering/hs-speedscope/pull/15) +* Abstract the conversion of events into samples [#17](https://github.com/mpickering/hs-speedscope/pull/17) +* Relax ghc-events bound [#19](https://github.com/mpickering/hs-speedscope/pull/19) +* Fix building with ghc-events-0.20 [#22](https://github.com/mpickering/hs-speedscope/pull/22) +* Add CI for recent GHCs and build bindists [#24](https://github.com/mpickering/hs-speedscope/pull/24) + ## 0.2.1 -- 2020-12-19 * Support ghc-events 0.13, 0.14 and 0.15. diff --git a/hs-speedscope.cabal b/hs-speedscope.cabal --- a/hs-speedscope.cabal +++ b/hs-speedscope.cabal @@ -4,7 +4,7 @@ -- http://haskell.org/cabal/users-guide/ name: hs-speedscope -version: 0.2.1 +version: 0.3.0 synopsis: Convert an eventlog into the speedscope json format description: Convert an eventlog into the speedscope json format. The interactive visualisation displays an approximate trace of the program and summary views akin to .prof files. @@ -17,27 +17,34 @@ maintainer: matthewtpickering@gmail.com -- copyright: category: Development -tested-with: GHC==8.8.1 -extra-source-files: CHANGELOG.md - README.md +tested-with: + GHC ==9.12.1 + GHC ==9.10.1 + GHC ==9.8.4 + GHC ==9.6.6 + GHC ==9.4.8 + GHC ==9.2.8 +extra-doc-files: CHANGELOG.md + README.md source-repository head type: git location: https://github.com/mpickering/hs-speedscope.git library - exposed-modules: HsSpeedscope - other-modules: Paths_hs_speedscope - autogen-modules: Paths_hs_speedscope - -- other-modules: + exposed-modules: + HsSpeedscope + Speedscope.Schema -- other-extensions: build-depends: base >= 4.12.0.0 && < 5, - ghc-events >= 0.13 && < 0.16, - aeson >= 1.4, - text >= 1.2, - vector >= 0.12, - extra >= 1.6, - optparse-applicative >= 0.15, + ghc-events >= 0.13 && < 0.21, + aeson >= 1.4 && < 2.3, + text >= 1.2 && < 2.2, + vector >= 0.12 && < 0.14, + optparse-applicative >= 0.15.0 && < 0.20, + extra >= 1.7 && < 1.9, + machines >= 0.7 && < 0.8, + hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/HsSpeedscope.hs b/src/HsSpeedscope.hs --- a/src/HsSpeedscope.hs +++ b/src/HsSpeedscope.hs @@ -1,26 +1,39 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -module HsSpeedscope where +{-# language CPP #-} +{-# language DuplicateRecordFields #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language ViewPatterns #-} +module HsSpeedscope ( + entry, + convertToSpeedscope, + processEventsDefault, + isInfoEvent, + parseIdent, + EventLogProfile(..), + CostCentre(..), + Sample(..) +) where +import Data.String ( fromString ) +import Control.Monad import Data.Aeson -import GHC.RTS.Events hiding (header, str) - -import Data.Word -import Data.Text (Text) +import Data.Char +import Data.Functor.Identity (Identity (..)) +import Data.List.Extra +import Data.Machine (Moore (..), source, (~>), ProcessT, PlanT, Is, construct, await, yield) +import Data.Machine.Runner (foldlT) +import Data.Maybe import qualified Data.Text +import Data.Text (Text) import qualified Data.Vector.Unboxed as V -import Data.Maybe -import Data.List.Extra -import Control.Monad -import Data.Char - import Data.Version -import Text.ParserCombinators.ReadP -import qualified Paths_hs_speedscope as Paths - -import Options.Applicative hiding (optional) +import Data.Word +import GHC.RTS.Events hiding (header, str) import qualified Options.Applicative as O +import Options.Applicative hiding (optional) +import Speedscope.Schema +import Text.ParserCombinators.ReadP hiding (between) data SSOptions = SSOptions { file :: FilePath @@ -53,60 +66,129 @@ <> header "hs-speedscope" ) run :: SSOptions -> IO () -run os = do - el <- either error id <$> readEventLogFromFile (file os) - encodeFile (file os ++ ".json") (convertToSpeedscope (isolateStart os, isolateEnd os) el) - -data ReadState = - ReadAll -- Ignore all future - | IgnoreUntil Text ReadState - | ReadUntil Text ReadState - | IgnoreAll deriving Show +run SSOptions{ file, isolateStart, isolateEnd } = do + el <- either error id <$> readEventLogFromFile file + encodeFile (file ++ ".json") (convertToSpeedscope (isolateStart, isolateEnd) isInfoEvent processEventsDefault el) -shouldRead :: ReadState -> Bool -shouldRead ReadAll = True -shouldRead (ReadUntil {}) = True -shouldRead _ = False +-- | A Moore machine whose state indicates which delimiting markers have been +-- seen. If both markers are 'Nothing', then the state will always be 'True'. +-- If the first marker is given, then the state will always be 'False' until a +-- value which the marker is a prefix of is seen. If the second marker is given, +-- then the state will always be 'False' after a value which the marker is a +-- prefix of is seen. +markers :: (Maybe Text, Maybe Text) -> Moore Text Bool +markers (Nothing, Nothing) = + go + where + go = Moore True (const go) +markers (Just s, Nothing) = + wait_for_start + where + wait_for_start = + Moore False $ \s' -> + if s `Data.Text.isPrefixOf` s' then + go + else + wait_for_start + go = Moore True (const go) +markers (Nothing, Just e) = + go_until + where + go_until = + Moore True $ \e' -> + if e `Data.Text.isPrefixOf` e' then + stop + else + go_until + stop = Moore False (const stop) +markers (Just s, Just e) = + go_between + where + go_between = + Moore False wait_for_start + where + wait_for_start s' = if s `Data.Text.isPrefixOf` s' then go_until else go_between + go_until = + Moore True close' + where + close' e' = if e `Data.Text.isPrefixOf` e' then stop else go_until + stop = Moore False (const stop) -transition :: Text -> ReadState -> ReadState -transition s r = case r of - (ReadUntil is n) | is `Data.Text.isPrefixOf` s -> n - (IgnoreUntil is n) | is `Data.Text.isPrefixOf` s -> n - _ -> r +-- | Delimit the event process, and only include events which satisfy a +-- predicate. +delimit + :: Monad m + => (EventInfo -> Bool) + -- ^ Only emit events which pass this predicate + -> Moore Text Bool + -- ^ Only emit events when this 'Moore' process state is 'True'. The process + -- will be given the values of 'UserMarker's in the event log. + -> ProcessT m Event Event +delimit p = + construct . go + where + go :: Monad m => Moore Text Bool -> PlanT (Is Event) Event m () + go mm@(Moore s next) = do + e <- await + case evSpec e of + -- on marker step the moore machine. + UserMarker m -> do + let mm'@(Moore s' _) = next m + -- if current or next state is open (== True), emit the marker. + when (s || s') $ yield e + go mm' -initState :: Maybe Text -> Maybe Text -> ReadState -initState Nothing Nothing = ReadAll -initState (Just s) e = IgnoreUntil s (initState Nothing e) -initState Nothing (Just e) = ReadUntil e IgnoreAll + -- for other events, emit if the state is open and predicate passes + ei -> do + when (s || p ei) $ yield e + go mm -convertToSpeedscope :: (Maybe Text, Maybe Text) -> EventLog -> Value -convertToSpeedscope (is, ie) (EventLog _h (Data (sortOn evTime -> es))) = +-- | Convert an 'EventLog' into a speedscope profile JSON value. To convert the +-- event log using the traditional profile extraction logic, use `isInfoEvent` +-- and `processEventsDefault` for the predicate and processing function, +-- respectively. +convertToSpeedscope + :: (Maybe Text, Maybe Text) + -- ^ Delimiting markers. No events before a user marker containing the first + -- string will be included. No events after a user marker containing the + -- second string will be included. + -> (EventInfo -> Bool) + -- ^ Only consider events which satisfy this predicate + -> (EventLogProfile -> Event -> EventLogProfile) + -- ^ Specifies how to build the profile given the events included based on the + -- delimiters and predicate + -> EventLog + -> Value +convertToSpeedscope (is, ie) considerEvent processEvents (EventLog _h (Data (sortOn evTime -> es))) = case el_version of Just (ghc_version, _) | ghc_version < makeVersion [8,9,0] -> error ("Eventlog is from ghc-" ++ showVersion ghc_version ++ " hs-speedscope only works with GHC 8.10 or later") - _ -> object [ "version" .= ("0.0.1" :: String) - , "$schema" .= ("https://www.speedscope.app/file-format-schema.json" :: String) - , "shared" .= object [ "frames" .= ccs_json ] - , "profiles" .= map (mkProfile profile_name interval) caps - , "name" .= profile_name - , "activeProfileIndex" .= (0 :: Int) - , "exporter" .= version_string - ] + _ -> toJSON file + where + file = File + { shared = Shared{ frames = ccs_json } + , profiles = map (mkProfile profile_name interval) caps + , name = Just profile_name + , activeProfileIndex = Just 0 + , exporter = Just $ fromString version_string + } where - (EL (fromMaybe "" -> profile_name) el_version (fromMaybe 1 -> interval) frames samples) = - snd $ foldl' (flip processEvents) (initState is ie, initEL) es + Identity (EventLogProfile (fromMaybe "" -> profile_name) el_version (fromMaybe 1 -> interval) frames samples) = + foldlT processEvents initEL $ + source es ~> + delimit considerEvent (markers (is, ie)) - initEL = EL Nothing Nothing Nothing [] [] + initEL = EventLogProfile Nothing Nothing Nothing [] [] version_string :: String - version_string = "hs-speedscope@" ++ showVersion Paths.version + version_string = "hs-speedscope@" ++ CURRENT_PACKAGE_VERSION -- Drop 7 events for built in cost centres like GC, IDLE etc ccs_raw = reverse (drop 7 (reverse frames)) - ccs_json :: [Value] + ccs_json :: [Frame] ccs_json = map mkFrame ccs_raw num_frames = length ccs_json @@ -115,44 +197,50 @@ caps :: [(Capset, [[Int]])] caps = groupSort $ mapMaybe mkSample (reverse samples) - mkFrame :: CostCentre -> Value - mkFrame (CostCentre _n l _m s) = object [ "name" .= l, "file" .= s ] + mkFrame :: CostCentre -> Frame + mkFrame (CostCentre _n name _m file) = Frame{ name, file = Just file, col = Nothing, line = Nothing } mkSample :: Sample -> Maybe (Capset, [Int]) -- Filter out system frames mkSample (Sample _ti [k]) | fromIntegral k >= num_frames = Nothing mkSample (Sample ti ccs) = Just (ti, map (subtract 1 . fromIntegral) (reverse ccs)) +-- | Default processing function to convert profiling events into a classic speedscope +-- profile +processEventsDefault :: EventLogProfile -> Event -> EventLogProfile +processEventsDefault elProf (Event _t ei _c) = + case ei of + ProgramArgs _ (pname: _args) -> + elProf { prog_name = Just pname } + RtsIdentifier _ rts_ident -> + elProf { rts_version = parseIdent rts_ident } + ProfBegin ival -> + elProf { prof_interval = Just ival } + HeapProfCostCentre n l m s _ -> + elProf { cost_centres = CostCentre n l m s : cost_centres elProf } + ProfSampleCostCentre t _ _ st -> + elProf { el_samples = Sample (fromIntegral t) (V.toList st) : el_samples elProf } + _ -> + elProf - processEvents :: Event -> (ReadState, EL) -> (ReadState, EL) - processEvents (Event _t ei _c) (do_sample, el) = - case ei of - ProgramArgs _ (pname: _args) -> - (do_sample, el { prog_name = Just pname }) - RtsIdentifier _ rts_ident -> - (do_sample, el { rts_version = parseIdent rts_ident }) - ProfBegin ival -> - (do_sample, el { prof_interval = Just ival }) - HeapProfCostCentre n l m s _ -> - (do_sample, el { cost_centres = CostCentre n l m s : cost_centres el }) - ProfSampleCostCentre t _ _ st -> - if shouldRead do_sample then - (do_sample, el { el_samples = Sample t (V.toList st) : el_samples el }) - else (do_sample, el) - (UserMarker m) -> (transition m do_sample, el) - _ -> (do_sample, el) +isInfoEvent :: EventInfo -> Bool +isInfoEvent ProgramArgs {} = True +isInfoEvent RtsIdentifier {} = True +isInfoEvent ProfBegin {} = True +isInfoEvent HeapProfCostCentre {} = True +isInfoEvent _ = False -mkProfile :: Text -> Word64 -> (Capset, [[Int]]) -> Value -mkProfile pname interval (_n, samples) = - object [ "type" .= ("sampled" :: String) - , "unit" .= ("nanoseconds" :: String) - , "name" .= pname - , "startValue" .= (0 :: Int) - , "endValue" .= (length samples :: Int) - , "samples" .= samples - , "weights" .= sample_weights ] +mkProfile :: Text -> Word64 -> (Capset, [[Int]]) -> Profile +mkProfile pname interval (_n, samples) = SampledProfile sampledProfile where - sample_weights :: [Word64] + sampledProfile = MkSampledProfile + { unit = Nanoseconds + , name = pname + , startValue = 0 + , endValue = length samples + , weights = fromIntegral <$> sample_weights + , samples + } sample_weights = replicate (length samples) interval parseIdent :: Text -> Maybe (Version, Text) @@ -168,13 +256,14 @@ convert x = (\(a, b) -> (a, Data.Text.pack b)) <$> x -data EL = EL { - prog_name :: Maybe Text - , rts_version :: Maybe (Version, Text) - , prof_interval :: Maybe Word64 - , cost_centres :: [CostCentre] - , el_samples :: [Sample] -} +-- | The type we wish to convert event logs into +data EventLogProfile = EventLogProfile + { prog_name :: Maybe Text + , rts_version :: Maybe (Version, Text) + , prof_interval :: Maybe Word64 + , cost_centres :: [CostCentre] + , el_samples :: [Sample] + } data CostCentre = CostCentre Word32 Text Text Text deriving Show diff --git a/src/Speedscope/Schema.hs b/src/Speedscope/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Speedscope/Schema.hs @@ -0,0 +1,91 @@ +{-# language DeriveAnyClass #-} +{-# language OverloadedStrings #-} +{-# language DuplicateRecordFields #-} +{-# language DeriveGeneric #-} +{-# language LambdaCase #-} +{-# language RecordWildCards #-} + +module Speedscope.Schema + ( File(..) + , Shared(..) + , Frame(..) + , Profile(..) + , SampledProfile(..) + , Unit(..) + ) where + +import Data.Char ( toLower ) +import Data.Aeson ( ToJSON(..), object, (.=), Value( String ) ) +import GHC.Generics ( Generic ) +import Data.Text ( Text ) + + +data File = File + { activeProfileIndex :: Maybe Int + , exporter :: Maybe Text + , name :: Maybe Text + , profiles :: [Profile] + , shared :: Shared + } + + +instance ToJSON File where + toJSON File{..} = object + [ "$schema" .= String "https://www.speedscope.app/file-format-schema.json" + , "activeProfileIndex" .= activeProfileIndex + , "exporter" .= exporter + , "name" .= name + , "profiles" .= profiles + , "shared" .= shared + ] + + +newtype Shared = Shared + { frames :: [Frame] + } deriving ( Generic, ToJSON ) + + +data Frame = Frame + { col :: Maybe Int + , file :: Maybe Text + , line :: Maybe Int + , name :: Text + } deriving ( Generic, ToJSON ) + + +data Profile = SampledProfile SampledProfile + + +instance ToJSON Profile where + toJSON = \case + SampledProfile p -> toJSON p + + +data SampledProfile = MkSampledProfile + { endValue :: Int + , name :: Text + , samples :: [[Int]] + , startValue :: Int + , unit :: Unit + , weights :: [Int] + } + + +instance ToJSON SampledProfile where + toJSON MkSampledProfile{..} = object + [ "endValue" .= endValue + , "name" .= name + , "samples" .= samples + , "startValue" .= startValue + , "unit" .= unit + , "weights" .= weights + , "type" .= String "sampled" + ] + + +data Unit = Nanoseconds + deriving Show + + +instance ToJSON Unit where + toJSON = toJSON . map toLower . show