diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# Revision history for ghc-stack-profiler-speedscope + +## 0.1.0.0 -- 2025-12-09 + +* Export an `.eventlog` file to speedscope. +* First version. Released on an unsuspecting world. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import Control.Exception.Backtrace +import GHC.Stack.Profiler.Speedscope + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + entry diff --git a/ghc-stack-profiler-speedscope.cabal b/ghc-stack-profiler-speedscope.cabal new file mode 100644 --- /dev/null +++ b/ghc-stack-profiler-speedscope.cabal @@ -0,0 +1,76 @@ +cabal-version: 3.8 +name: ghc-stack-profiler-speedscope +version: 0.1.0.0 +license: BSD-3-Clause +author: Hannes Siebenhandl, Wen Kokke, Matthew Pickering +maintainer: hannes@well-typed.com +build-type: Simple +synopsis: Convert eventlog messages from `ghc-stack-profiler` into a speedscope json. +description: + Convert eventlog messages from `ghc-stack-profiler` into a speedscope json. + Produce a flame graph for the RTS callstack samples obtained from a program instrumented with + 'ghc-stack-profiler'. + +extra-doc-files: CHANGELOG.md +category: Profiling, Benchmarking, Development +tested-with: ghc ==9.14 || ==9.12 || ==9.10 + +common warnings + ghc-options: + -Wall + -Wunused-packages + +common exts + default-extensions: + DeriveGeneric + DerivingStrategies + DuplicateRecordFields + LambdaCase + NamedFieldPuns + ViewPatterns + +common runopts + ghc-options: + -threaded + -rtsopts + +library + import: + warnings, exts + + exposed-modules: + GHC.Stack.Profiler.Speedscope + + build-depends: + aeson >=2.2 && <2.3, + base >=4.20 && <4.23, + bytestring >=0.11 && <0.13, + containers >=0.6.8 && <0.9, + extra ^>=1.8.1, + ghc-events ^>=0.20, + ghc-stack-profiler-core ^>=0.1, + hs-speedscope ^>=0.3, + machines ^>=0.7.4, + optparse-applicative ^>=0.19, + text >=2 && <2.2, + + hs-source-dirs: + src + + default-language: GHC2021 + +executable ghc-stack-profiler-speedscope + import: + warnings, exts, runopts + + hs-source-dirs: + app + + main-is: + Main.hs + + build-depends: + base, + ghc-stack-profiler-speedscope, + + default-language: GHC2021 diff --git a/src/GHC/Stack/Profiler/Speedscope.hs b/src/GHC/Stack/Profiler/Speedscope.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Speedscope.hs @@ -0,0 +1,535 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.Stack.Profiler.Speedscope where + +import Data.String ( fromString ) +import Control.Monad +import Data.Aeson +import Data.Char +import Data.Tuple +import Data.Functor.Identity (Identity (..)) +import qualified Data.ByteString.Lazy as LBS +import Data.List.Extra +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Machine (Moore (..), source, (~>), ProcessT, PlanT, Is, construct, await, yield) +import Data.Machine.Runner (foldlT) +import Data.Maybe +import qualified Data.Text as Text +import qualified Data.Text.Read as Read +import Data.Text (Text) +import Data.Version +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) +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.IntMap (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Coerce (coerce) + +import GHC.Stack.Profiler.Core.ThreadSample as ThreadSample +import GHC.Stack.Profiler.Core.Util +import GHC.Stack.Profiler.Core.Eventlog +import GHC.Stack.Profiler.Core.SymbolTable + +data SSOptions = SSOptions + { file :: FilePath + , isolateStart :: Maybe Text + , isolateEnd :: Maybe Text + , aggregationMode :: Aggregation + } deriving Show + +data Aggregation + = PerThread + | PerCapability + | NoAggregation + deriving (Show, Eq, Ord) + +optsParser :: Parser SSOptions +optsParser = SSOptions + <$> argument str (metavar "FILE.eventlog") + <*> O.optional (strOption + ( short 's' + <> long "start" + <> metavar "STRING" + <> help "No samples before the first eventlog message with this prefix will be included in the output" )) + <*> O.optional (strOption + ( short 'e' <> long "end" <> metavar "STRING" <> help "No samples after the first eventlog message with this prefix will be included in the output" )) + <*> + ( flag' PerThread (long "per-thread" <> help "Group the profile per thread (default)") + <|> flag' PerCapability (long "per-capability" <> help "Group the profile per capability") + <|> flag' NoAggregation (long "no-aggregation" <> help "Perform no grouping, single view") + <|> pure PerThread + ) + +entry :: IO () +entry = do + os <- execParser opts + run os + where + opts = info (optsParser <**> helper) + ( fullDesc + <> progDesc "Generate a speedscope.app json file from an eventlog" + <> header "hs-speedscope" ) + +run :: SSOptions -> IO () +run SSOptions{ file, isolateStart, isolateEnd, aggregationMode } = do + -- We extract the 'InfoProv's before collecting the thread samples to avoid + -- having to sort the 'InfoProv's and causing a memory leak. + -- We reduce the memory usage considerably by doing this separately. + elIpe <- either error id <$> readEventLogFromFile file + let infoProv = parseIpeTraces (isolateStart, isolateEnd) elIpe + + -- Now do the actual work + el <- either error id <$> readEventLogFromFile file + encodeFile (file ++ ".json") (convertToSpeedscope aggregationMode (isolateStart, isolateEnd) isInfoEvent processEventsDefault infoProv el) + +-- | 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 `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 `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 `Text.isPrefixOf` s' then go_until else go_between + go_until = + Moore True close' + where + close' e' = if e `Text.isPrefixOf` e' then stop else go_until + stop = Moore False (const stop) + +-- | 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' + + -- for other events, emit if the state is open and predicate passes + ei -> do + when (s || p ei) $ yield e + go mm + +parseIpeTraces + :: (Maybe Text, Maybe Text) + -> EventLog + -> IntMap InfoProv +parseIpeTraces (is, ie) (EventLog _h (Data es)) = + info_provs + where + Identity info_provs = + foldlT processIpeEventsDefault initEL $ + source es ~> + delimit isIpeInfoEvent (markers (is, ie)) + + initEL = IntMap.empty + +-- | 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 + :: Aggregation + -- ^ How to aggregate the stack profile samples + -> (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 + -> IntMap InfoProv + -- ^ Already gathered table for 'InfoProv's that have been collected prior. + -> EventLog + -> Value +convertToSpeedscope mode (is, ie) considerEvent processEvents infoProvs (EventLog _h (Data 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") + _ -> toJSON file + where + file = File + { shared = Shared{ frames = all_frames } + , profiles = map (mkProfile profile_name interval) stack_profile_samples + , name = Just profile_name + , activeProfileIndex = Just 0 + , exporter = Just $ fromString version_string + } + where + Identity (EventLogProfile (fromMaybe "" -> profile_name) el_version (fromMaybe 1 -> interval) _infoProvs userCostCentres _counter samples _ _) = + foldlT processEvents initEL $ + source es ~> + delimit considerEvent (markers (is, ie)) + + initEL = EventLogProfile + { prog_name = Nothing + , rts_version = Nothing + , prof_interval = Nothing + , info_provs = infoProvs + , user_cost_centres = Map.empty + , cost_centre_counter = 0 + , el_samples = [] + , hydration_table = emptyIntMapTable + , current_callstack_chunks = [] + } + + version_string :: String + version_string = "hs-speedscope@" ++ CURRENT_PACKAGE_VERSION + + all_frames :: [Frame] + all_frames = + map snd . sortOn fst $ + map (fmap mkCostCentreFrame) (Map.elems userCostCentres) + + stack_profile_samples :: [(Word64, [[Int]])] + stack_profile_samples = + case mode of + PerThread -> + -- groupSort is assumed to be stable + groupSort $ map mkThreadSample (reverse samples) + PerCapability -> + -- groupSort is assumed to be stable + groupSort $ map mkCapabilitySample (reverse samples) + NoAggregation -> + [(1, map mkSingleProfileSample (reverse samples))] + + mkCostCentreFrame :: UserCostCentre -> Frame + mkCostCentreFrame = \ case + CostCentreMessage msg -> + Frame + { name = msg + , file = Nothing + , col = Nothing + , line = Nothing + } + CostCentreSrcLoc loc -> + Frame + { name = functionName loc + , file = Just $ fileName loc + , col = Just $ word32ToInt $ ThreadSample.column loc + , line = Just $ word32ToInt $ ThreadSample.line loc + } + CostCentreIpe InfoProv{infoTableName, infoProvModule, infoProvLabel, infoProvSrcLoc} -> + Frame + { name = + if Text.null infoProvLabel + then infoProvModule <> " " <> infoTableName + else infoProvModule <> " " <> infoProvLabel + , file = if infoProvSrcLoc == ":" then Just infoProvModule else fileName + , col = columnM + , line = lineM + } + where + (fileName, lineM, columnM) = tryParsingGhcSrcSpan infoProvSrcLoc + + mkThreadSample :: Sample -> (Word64, [Int]) + mkThreadSample (Sample ti _capId ccs) = (ti, map (word64ToInt . coerce) ccs) + + mkCapabilitySample :: Sample -> (Word64, [Int]) + mkCapabilitySample (Sample _ti capId ccs) = (coerce capId, map (word64ToInt . coerce) ccs) + + mkSingleProfileSample :: Sample -> [Int] + mkSingleProfileSample (Sample _ti _capId ccs) = map (word64ToInt . coerce) ccs + +-- TODO: parsing of various src span formats +-- currently supported: +-- * filename.hs:1:1 +-- * filename.hs:1-4:1 +-- * filename.hs:1:1-4 +-- * filename.hs:1-4:1-4 (this one doesn't mean anything) +-- +-- missing: +-- * filename.hs:(154,1)-(155,32) +tryParsingGhcSrcSpan :: Text -> (Maybe Text, Maybe Int, Maybe Int) +tryParsingGhcSrcSpan srcSpan = + case Text.splitOn ":" srcSpan of + (fn:srcLoc) -> case srcLoc of + (rowSpan: columnSpan:_) -> + let + getStartOfSpan sp = case Text.splitOn "-" sp of + start:_ -> readAsNumber start + _ -> Nothing + in + (Just fn, getStartOfSpan rowSpan, getStartOfSpan columnSpan) + _ -> + (Just fn, Nothing, Nothing) + _ -> + (Nothing, Nothing, Nothing) + where + readAsNumber n = case Read.decimal n of + Left _ -> Nothing + Right (number, _) -> Just number + +processIpeEventsDefault :: InfoProvMap -> Event -> InfoProvMap +processIpeEventsDefault provMap (Event _t ei _c) = + case ei of + InfoTableProv { itTableName, itClosureDesc, itTyDesc, itInfo, itLabel, itSrcLoc, itModule } -> + let + key = InfoProvId itInfo + prov = InfoProv + { infoProvId = InfoProvId itInfo + , infoProvSrcLoc = itSrcLoc + , infoProvModule = itModule + , infoProvLabel = itLabel + , infoTableName = itTableName + , infoClosureDesc = itClosureDesc + , infoTyDesc = itTyDesc + } + in + IntMap.insert (word64ToInt $ coerce key) prov provMap + _ -> + provMap + +-- | 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 } + UserBinaryMessage bs -> + case deserializeEventlogMessage $ LBS.fromStrict bs of + Left _err -> + elProf + Right evMsg -> case evMsg of + CallStackFinal msg -> + let + (callStackMessage, elProf1) = + hydrateBinaryEventlog elProf msg + in + addCallStackToProfile elProf1 callStackMessage + + CallStackChunk msg -> + elProf { current_callstack_chunks = msg : current_callstack_chunks elProf } + StringDef msg -> + elProf { hydration_table = insertTextMessage msg (hydration_table elProf) } + SourceLocationDef msg -> + elProf { hydration_table = insertSourceLocationMessage msg (hydration_table elProf) } + _ -> + elProf + +addCallStackToProfile :: EventLogProfile -> CallStackMessage -> EventLogProfile +addCallStackToProfile elProf MkCallStackMessage{callThreadId, callCapabilityId, callStack} = + let + (newProf, ccs) = mapAccumR go elProf callStack + go prof csi = + swap $ lookupOrAddStackItemToProfile prof csi + sample = Sample + { sampleThreadId = callThreadId + , sampleCapabilityId = callCapabilityId + , sampleCostCentreStack = + -- TODO: Don't do the arbitrary cutoff, but reduce cycles. + -- And then do an arbitrary cutoff as speedscope has limits. + take 1000 $ reverse ccs + } + in + newProf + { el_samples = sample : el_samples newProf + } + +hydrateBinaryEventlog :: EventLogProfile -> BinaryCallStackMessage -> (CallStackMessage, EventLogProfile) +hydrateBinaryEventlog elProf msg = + let + chunks = current_callstack_chunks elProf + -- Why reverse? + -- When decoding the stack, we walk the stack from the top down. + -- Afterwards, the stack is chunked to fit into a single eventlog line, + -- and the chunks are written in ascending order to the eventlog. + -- When we pick up these messages one after another, they are prepended to + -- 'current_callstack_chunks', thus we are essentially storing the chunks in reverse + -- order, as the first chunk we encounter is the top of the stack, etc... + -- + -- Concrete example, assuming a stack @[1,2,3,4,5,6]@ and chunk size of 2: + -- + -- 1. Chunk it: @[1,2] [3,4] [5,6]@ + -- 2. Write it to the eventlog in this order, so the messages are: + -- [1,2] + -- [3,4] + -- [5,6] + -- 3. When reading the eventlog, we store prepend later messages, resulting in: + -- [5,6] [3,4] [1,2] + -- 4. One reverse later: @[1,2] [3,4] [5,6]@ + -- 5. Now we can finally concat the stack frame chunks. + orderedChunks = NonEmpty.reverse $ msg :| chunks + fullBinaryCallStackMessage = catCallStackMessage orderedChunks + callStackMessage = + hydrateEventlogCallStackMessage + (mkIntMapSymbolTableReader (hydration_table elProf)) + fullBinaryCallStackMessage + in + ( callStackMessage + , elProf { current_callstack_chunks = [] } + ) + +lookupOrAddStackItemToProfile :: EventLogProfile -> StackItem -> (CostCentreId, EventLogProfile) +lookupOrAddStackItemToProfile elProf = \ case + IpeId iid -> + lookupOrInsertCostCentre (CostCentreIpe (info_provs elProf IntMap.! idToInt iid)) + ThreadSample.UserMessage msg -> + lookupOrInsertCostCentre (CostCentreMessage $ fromString msg) + SourceLocation loc -> + lookupOrInsertCostCentre (CostCentreSrcLoc loc) + where + lookupOrInsertCostCentre userMessage = + case Map.lookup userMessage (user_cost_centres elProf) of + Just (cid, _) -> (cid, elProf) + Nothing -> + let + key = userMessage + cid = cost_centre_counter elProf + in + ( cid + , elProf + { cost_centre_counter = cid + 1 + , user_cost_centres = Map.insert key (cid, key) (user_cost_centres elProf) + } + ) + +isIpeInfoEvent :: EventInfo -> Bool +isIpeInfoEvent InfoTableProv {} = True +isIpeInfoEvent _ = False + +isInfoEvent :: EventInfo -> Bool +isInfoEvent ProgramArgs {} = True +isInfoEvent RtsIdentifier {} = True +isInfoEvent ProfBegin {} = True +isInfoEvent UserBinaryMessage {} = True +isInfoEvent _ = False + +mkProfile :: Text -> Word64 -> (Word64, [[Int]]) -> Profile +mkProfile pname interval (n, samples) = SampledProfile sampledProfile + where + sampledProfile = MkSampledProfile + { unit = Nanoseconds + , name = pname <> " " <> Text.show n + , startValue = 0 + , endValue = length samples + , weights = fromIntegral <$> sample_weights + , samples + } + sample_weights = replicate (length samples) interval + +parseIdent :: Text -> Maybe (Version, Text) +parseIdent s = convert $ listToMaybe $ flip readP_to_S (Text.unpack 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 + + convert x = (\(a, b) -> (a, Text.pack b)) <$> x + +type InfoProvMap = IntMap InfoProv + +-- | 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 + , info_provs :: InfoProvMap + -- ^ Table of present 'InfoProv's in the eventlog + , user_cost_centres :: !(Map UserCostCentre (CostCentreId, UserCostCentre)) + -- ^ All "cost centres" that are actually mentioned by `ghc-stack-profiler`. + , cost_centre_counter :: !CostCentreId + -- ^ Unique Counter for the 'Sample's + , el_samples :: [Sample] + -- ^ All samples in the reverse order of finding them in the eventlog. + , hydration_table :: !IntMapTable + -- ^ The symbol table storing 'Text' and 'SourceLocation' symbols + -- for hydrating a 'BinaryCallStackMessage' into a 'CallStackMessage'. + , current_callstack_chunks :: [BinaryCallStackMessage] + -- ^ Chunks of 'BinaryCallStackMessage' we are currently decoding. + -- All chunks are assumed to be from the same callstack and will be decoded once a + -- 'CallStackFinal' message is encountered. + } deriving (Eq, Ord, Show) + +newtype CostCentreId = CostCentreId Word64 + deriving (Eq, Ord, Show) + deriving newtype (Num) + +newtype InfoProvId = InfoProvId Word64 + deriving (Eq, Ord, Show) + +data UserCostCentre + = CostCentreMessage !Text + | CostCentreSrcLoc !SourceLocation + | CostCentreIpe !InfoProv + deriving (Eq, Ord, Show) + +data InfoProv = InfoProv + { infoProvId :: !InfoProvId + , infoProvSrcLoc :: !Text + , infoProvModule :: !Text + , infoProvLabel :: !Text + , infoTableName :: !Text + , infoClosureDesc :: !Int + , infoTyDesc :: !Text + } deriving (Eq, Ord, Show) + +data Sample = Sample + { sampleThreadId :: !Word64 -- ^ thread id + , sampleCapabilityId :: !CapabilityId -- ^ Capability id + , sampleCostCentreStack :: [CostCentreId] -- ^ stack ids + } + deriving (Eq, Ord, Show)