hs-speedscope 0.2.1 → 0.3.0
raw patch · 4 files changed
+300/−103 lines, 4 filesdep +machinesdep ~aesondep ~basedep ~extranew-uploader
Dependencies added: machines
Dependency ranges changed: aeson, base, extra, ghc-events, optparse-applicative, text, vector
Files
- CHANGELOG.md +10/−0
- hs-speedscope.cabal +21/−14
- src/HsSpeedscope.hs +178/−89
- src/Speedscope/Schema.hs +91/−0
CHANGELOG.md view
@@ -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.
hs-speedscope.cabal view
@@ -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
src/HsSpeedscope.hs view
@@ -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
+ src/Speedscope/Schema.hs view
@@ -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