diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for ghc-stack-profiler-speedscope +## 0.2.0.0 -- 2026-04-10 + +* Support ipedb to store InfoProvs [#8](https://github.com/well-typed/ghc-stack-profiler/pull/8) + ## 0.1.0.0 -- 2025-12-09 * Export an `.eventlog` file to speedscope. diff --git a/ghc-stack-profiler-speedscope.cabal b/ghc-stack-profiler-speedscope.cabal --- a/ghc-stack-profiler-speedscope.cabal +++ b/ghc-stack-profiler-speedscope.cabal @@ -1,6 +1,6 @@ cabal-version: 3.8 name: ghc-stack-profiler-speedscope -version: 0.1.0.0 +version: 0.2.0.0 license: BSD-3-Clause author: Hannes Siebenhandl, Wen Kokke, Matthew Pickering maintainer: hannes@well-typed.com @@ -13,7 +13,10 @@ extra-doc-files: CHANGELOG.md category: Profiling, Benchmarking, Development -tested-with: ghc ==9.14 || ==9.12 || ==9.10 +tested-with: + ghc ==9.10.3 + ghc ==9.12.2 + ghc ==9.14.1 common warnings ghc-options: @@ -27,6 +30,7 @@ DuplicateRecordFields LambdaCase NamedFieldPuns + NoImportQualifiedPost ViewPatterns common runopts @@ -40,16 +44,20 @@ exposed-modules: GHC.Stack.Profiler.Speedscope + GHC.Stack.Profiler.Speedscope.IpeDb + GHC.Stack.Profiler.Speedscope.Options + GHC.Stack.Profiler.Speedscope.Types build-depends: aeson >=2.2 && <2.3, base >=4.20 && <4.23, - bytestring >=0.11 && <0.13, + 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, + ghc-stack-profiler-core ==0.2.0.0, hs-speedscope ^>=0.3, + ipedb ^>=0.1.0.0, machines ^>=0.7.4, optparse-applicative ^>=0.19, text >=2 && <2.2, @@ -74,3 +82,8 @@ ghc-stack-profiler-speedscope, default-language: GHC2021 + +source-repository head + type: git + location: https://github.com/well-typed/ghc-stack-profiler.git + subdir: ghc-stack-profiler-speedscope diff --git a/src/GHC/Stack/Profiler/Speedscope.hs b/src/GHC/Stack/Profiler/Speedscope.hs --- a/src/GHC/Stack/Profiler/Speedscope.hs +++ b/src/GHC/Stack/Profiler/Speedscope.hs @@ -1,94 +1,85 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} - module GHC.Stack.Profiler.Speedscope where -import Data.String ( fromString ) import Control.Monad import Data.Aeson +import qualified Data.ByteString.Lazy as LBS import Data.Char -import Data.Tuple +import Data.Coerce (coerce) import Data.Functor.Identity (Identity (..)) -import qualified Data.ByteString.Lazy as LBS +import Data.IntMap (IntMap) +import qualified Data.IntMap.Strict as IntMap import Data.List.Extra -import Data.List.NonEmpty (NonEmpty(..)) +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 (Is, Moore (..), PlanT, ProcessT, await, construct, source, yield, (~>)) import Data.Machine.Runner (foldlT) +import Data.Map (Map) +import qualified Data.Map.Strict as Map import Data.Maybe +import Data.String (fromString) +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Read as Read -import Data.Text (Text) +import Data.Tuple 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 GHC.RTS.Events hiding (StringId, header, str) +import qualified Options.Applicative as Options import Speedscope.Schema +import qualified System.IO.Unsafe as Unsafe 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 - ) +import GHC.Stack.Profiler.Core.ThreadSample as ThreadSample +import GHC.Stack.Profiler.Core.Util +import GHC.Stack.Profiler.Speedscope.IpeDb (toSpeedscopeInfoProv) +import GHC.Stack.Profiler.Speedscope.Options +import qualified GHC.Stack.Profiler.Speedscope.Options as IpeDbConf (IpeConf (..)) +import GHC.Stack.Profiler.Speedscope.Types +import qualified IpeDb.InfoProv as IpeDb +import qualified IpeDb.Query as IpeDb +import qualified IpeDb.Types as IpeDb +import Data.Either (partitionEithers) +import System.IO entry :: IO () entry = do - os <- execParser opts + os <- Options.execParser options 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 +run SSOptions{ file, isolateStart, isolateEnd, aggregationMode, ipeDbConf } = withOptionalIpeDb ipeDbConf $ \mInfoProvDb -> do -- We extract the 'InfoProv's before collecting the thread samples to avoid - -- having to sort the 'InfoProv's and causing a memory leak. + -- having to sort the 'InfoProv's and causing a space leak. -- We reduce the memory usage considerably by doing this separately. - elIpe <- either error id <$> readEventLogFromFile file - let infoProv = parseIpeTraces (isolateStart, isolateEnd) elIpe + oracle <- case mInfoProvDb of + Just (conf, db) -> do + case index conf of + True -> IpeDb.populateFromEventlog db file + False -> pure () + pure $ oracleFromInfoProvDb db + Nothing -> do + elIpe <- either error id <$> readEventLogFromFile file + let infoProv = parseIpeTraces (isolateStart, isolateEnd) elIpe + pure $ oracleFromMap infoProv -- Now do the actual work el <- either error id <$> readEventLogFromFile file - encodeFile (file ++ ".json") (convertToSpeedscope aggregationMode (isolateStart, isolateEnd) isInfoEvent processEventsDefault infoProv el) + profileJson <- convertToSpeedscope aggregationMode (isolateStart, isolateEnd) isInfoEvent processEventsDefault oracle el + encodeFile (file ++ ".json") profileJson +withOptionalIpeDb :: Maybe IpeConf -> (Maybe (IpeConf, IpeDb.InfoProvDb) -> IO a) -> IO () +withOptionalIpeDb mConf act = case mConf of + Nothing -> do + _ <- act Nothing + pure () + Just conf -> IpeDb.withInfoProvDb (IpeDbConf.file conf) $ \ db -> do + _ <- act (Just (conf, db)) + pure () + -- | 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 @@ -162,90 +153,36 @@ 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 - } +processEventLogProfileState :: Aggregation -> EventLogProfileState -> EventLogProfile +processEventLogProfileState mode evProfileState = + EventLogProfile + { profileProgName = profile_name + , profileFrames = all_frames + , profileProfiles = map (mkProfile profile_name interval) stack_profile_samples + , profileProgVersionString = Text.pack $ "ghc-stack-profiler-speedscope@" ++ CURRENT_PACKAGE_VERSION + , profileProcessingErrors = decoding_errors evProfileState + } 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 = [] - } + profile_name = fromMaybe "" (eventlog_prog_name evProfileState) - version_string :: String - version_string = "hs-speedscope@" ++ CURRENT_PACKAGE_VERSION + interval = fromMaybe 1 (prof_interval evProfileState) all_frames :: [Frame] all_frames = map snd . sortOn fst $ - map (fmap mkCostCentreFrame) (Map.elems userCostCentres) + map (fmap mkCostCentreFrame) (Map.elems $ user_cost_centres evProfileState) stack_profile_samples :: [(Word64, [[Int]])] stack_profile_samples = case mode of PerThread -> -- groupSort is assumed to be stable - groupSort $ map mkThreadSample (reverse samples) + groupSort $ map mkThreadSample (reverse $ el_samples evProfileState) PerCapability -> -- groupSort is assumed to be stable - groupSort $ map mkCapabilitySample (reverse samples) + groupSort $ map mkCapabilitySample (reverse $ el_samples evProfileState) NoAggregation -> - [(1, map mkSingleProfileSample (reverse samples))] + [(1, map mkSingleProfileSample (reverse $ el_samples evProfileState))] mkCostCentreFrame :: UserCostCentre -> Frame mkCostCentreFrame = \ case @@ -285,6 +222,68 @@ mkSingleProfileSample :: Sample -> [Int] mkSingleProfileSample (Sample _ti _capId ccs) = map (word64ToInt . coerce) ccs +-- | 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 + -> (EventLogProfileState -> Event -> EventLogProfileState) + -- ^ Specifies how to build the profile given the events included based on the + -- delimiters and predicate + -> InfoProvOracle + -- ^ Already gathered table for 'InfoProv's that have been collected prior. + -> EventLog + -> IO Value +convertToSpeedscope mode (is, ie) considerEvent processEvents infoProvOracle (EventLog _h (Data es)) = do + eventLogProfileState <- + foldlT processEvents initEL $ + source es ~> + delimit considerEvent (markers (is, ie)) + let eventlogProfile = processEventLogProfileState mode eventLogProfileState + logDecodingErrors eventlogProfile + pure $ toJSON File + { shared = Shared{ frames = profileFrames eventlogProfile } + , profiles = profileProfiles eventlogProfile + , name = Just $ profileProgName eventlogProfile + , activeProfileIndex = Just 0 + , exporter = Just $ profileProgVersionString eventlogProfile + } + where + initEL = EventLogProfileState + { eventlog_prog_name = Nothing + , rts_version = Nothing + , prof_interval = Nothing + , info_prov_oracle = infoProvOracle + , user_cost_centres = Map.empty + , cost_centre_counter = 0 + , el_samples = [] + , hydration_table = emptyIntMapTable + , current_callstack_chunks = [] + , decoding_errors = [] + } + + logDecodingErrors prof = case profileProcessingErrors prof of + [] -> pure () + errorStacks -> do + hPutStrLn stderr $ show (length errorStacks) ++ " CallStacks were decoded incompletely or not at all." + forM_ errorStacks $ \ stack -> do + let + size = length stack + + forM_ (take 10 stack) $ \ err -> do + hPutStrLn stderr (" " ++ prettyEventLogError err) + + when (size > 10) $ do + hPutStrLn stderr (" ... and " ++ show (size - 10) ++ " more." ) + -- TODO: parsing of various src span formats -- currently supported: -- * filename.hs:1:1 @@ -336,11 +335,11 @@ -- | Default processing function to convert profiling events into a classic speedscope -- profile -processEventsDefault :: EventLogProfile -> Event -> EventLogProfile +processEventsDefault :: EventLogProfileState -> Event -> EventLogProfileState processEventsDefault elProf (Event _t ei _c) = case ei of ProgramArgs _ (pname: _args) -> - elProf { prog_name = Just pname } + elProf { eventlog_prog_name = Just pname } RtsIdentifier _ rts_ident -> elProf { rts_version = parseIdent rts_ident } ProfBegin ival -> @@ -362,14 +361,20 @@ StringDef msg -> elProf { hydration_table = insertTextMessage msg (hydration_table elProf) } SourceLocationDef msg -> - elProf { hydration_table = insertSourceLocationMessage msg (hydration_table elProf) } + case insertSourceLocationMessage msg (hydration_table elProf) of + Left err -> + addDecodingErrorsForStack [fromMissingKeyError err] elProf + + Right newTable -> + elProf { hydration_table = newTable } _ -> elProf -addCallStackToProfile :: EventLogProfile -> CallStackMessage -> EventLogProfile +addCallStackToProfile :: EventLogProfileState -> CallStackMessage -> EventLogProfileState addCallStackToProfile elProf MkCallStackMessage{callThreadId, callCapabilityId, callStack} = let - (newProf, ccs) = mapAccumR go elProf callStack + (newProf, ccsOrError) = mapAccumR go elProf callStack + (errors, ccs) = partitionEithers ccsOrError go prof csi = swap $ lookupOrAddStackItemToProfile prof csi sample = Sample @@ -381,11 +386,13 @@ take 1000 $ reverse ccs } in - newProf - { el_samples = sample : el_samples newProf - } + addDecodingErrorsForStack + errors + newProf + { el_samples = sample : el_samples newProf + } -hydrateBinaryEventlog :: EventLogProfile -> BinaryCallStackMessage -> (CallStackMessage, EventLogProfile) +hydrateBinaryEventlog :: EventLogProfileState -> BinaryCallStackMessage -> (CallStackMessage, EventLogProfileState) hydrateBinaryEventlog elProf msg = let chunks = current_callstack_chunks elProf @@ -410,33 +417,42 @@ -- 5. Now we can finally concat the stack frame chunks. orderedChunks = NonEmpty.reverse $ msg :| chunks fullBinaryCallStackMessage = catCallStackMessage orderedChunks - callStackMessage = + (callStackMessage, errs) = hydrateEventlogCallStackMessage (mkIntMapSymbolTableReader (hydration_table elProf)) fullBinaryCallStackMessage in ( callStackMessage - , elProf { current_callstack_chunks = [] } + , addDecodingErrorsForStack + (map fromBinaryError errs) + elProf { current_callstack_chunks = [] } ) -lookupOrAddStackItemToProfile :: EventLogProfile -> StackItem -> (CostCentreId, EventLogProfile) +lookupOrAddStackItemToProfile :: EventLogProfileState -> StackItem -> (Either EventLogError CostCentreId, EventLogProfileState) lookupOrAddStackItemToProfile elProf = \ case - IpeId iid -> - lookupOrInsertCostCentre (CostCentreIpe (info_provs elProf IntMap.! idToInt iid)) + IpeId iid -> do + case findInfoProv (info_prov_oracle elProf) iid of + Nothing -> + (Left $ UnknownIpeId iid, elProf) + Just prov -> + lookupOrInsertCostCentre (CostCentreIpe prov) + 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) + Just (cid, _) -> (Right cid, elProf) Nothing -> let key = userMessage cid = cost_centre_counter elProf in - ( cid + ( Right cid , elProf { cost_centre_counter = cid + 1 , user_cost_centres = Map.insert key (cid, key) (user_cost_centres elProf) @@ -480,56 +496,107 @@ convert x = (\(a, b) -> (a, Text.pack b)) <$> x -type InfoProvMap = IntMap InfoProv +data EventLogProfile = EventLogProfile + { profileProgName :: Text + , profileFrames :: [Frame] + , profileProfiles :: [Profile] + , profileProgVersionString :: Text + , profileProcessingErrors :: [[EventLogError]] + } -- | 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) +data EventLogProfileState = EventLogProfileState + { eventlog_prog_name :: Maybe Text + , rts_version :: Maybe (Version, Text) + , prof_interval :: Maybe Word64 + , info_prov_oracle :: InfoProvOracle + -- ^ 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. + , decoding_errors :: [[EventLogError]] + } -newtype CostCentreId = CostCentreId Word64 - deriving (Eq, Ord, Show) - deriving newtype (Num) +addDecodingErrorsForStack :: [EventLogError] -> EventLogProfileState -> EventLogProfileState +addDecodingErrorsForStack errs elProf = + if null errs + then + elProf + else + elProf + { decoding_errors = errs : decoding_errors elProf + } -newtype InfoProvId = InfoProvId Word64 - deriving (Eq, Ord, Show) +-- ---------------------------------------------------------------------------- +-- Decoding errors +-- ---------------------------------------------------------------------------- -data UserCostCentre - = CostCentreMessage !Text - | CostCentreSrcLoc !SourceLocation - | CostCentreIpe !InfoProv - deriving (Eq, Ord, Show) +data EventLogError + = UnknownIpeId IpeId + | UnknownStringId StringId + | UnknownSrcLocId SourceLocationId + | SourceLocationPartUndefined SourceLocationId StringId + deriving (Show, Eq, Ord) -data InfoProv = InfoProv - { infoProvId :: !InfoProvId - , infoProvSrcLoc :: !Text - , infoProvModule :: !Text - , infoProvLabel :: !Text - , infoTableName :: !Text - , infoClosureDesc :: !Int - , infoTyDesc :: !Text - } deriving (Eq, Ord, Show) +fromBinaryError :: BinaryCallStackDecodeError -> EventLogError +fromBinaryError = \ case + StringIdNotFound sid -> UnknownStringId sid + SourceLocationIdNotFound sid -> UnknownSrcLocId sid -data Sample = Sample - { sampleThreadId :: !Word64 -- ^ thread id - , sampleCapabilityId :: !CapabilityId -- ^ Capability id - , sampleCostCentreStack :: [CostCentreId] -- ^ stack ids +fromMissingKeyError :: MissingKeyError -> EventLogError +fromMissingKeyError = \ case + KeyStringIdNotFound sourceLocId stringId -> SourceLocationPartUndefined sourceLocId stringId + +prettyEventLogError :: EventLogError -> String +prettyEventLogError = \ case + UnknownIpeId ipeId -> show $ UnknownIpeId ipeId + UnknownStringId sid -> show $ UnknownStringId sid + UnknownSrcLocId sid -> show $ UnknownSrcLocId sid + SourceLocationPartUndefined srcLocId stringId -> + "While decoding source location " ++ show srcLocId ++ ", failed to find string " ++ show stringId + +-- ---------------------------------------------------------------------------- +-- Oracle for Info Provs +-- ---------------------------------------------------------------------------- + +newtype InfoProvOracle = InfoProvOracle + { findInfoProv :: IpeId -> Maybe InfoProv } - deriving (Eq, Ord, Show) + +oracleFromMap :: IntMap InfoProv -> InfoProvOracle +oracleFromMap infoProvs = InfoProvOracle (\ipeId -> IntMap.lookup (idToInt ipeId) infoProvs) + +oracleFromInfoProvDb :: IpeDb.InfoProvDb -> InfoProvOracle +oracleFromInfoProvDb infoProvDb = InfoProvOracle $ \ipeId -> do + ipedb_info_prov <- Unsafe.unsafePerformIO (IpeDb.lookupInfoProv infoProvDb (IpeDb.IpeId (getIpeId ipeId))) + pure $ toSpeedscopeInfoProv ipedb_info_prov + +-- ---------------------------------------------------------------------------- +-- In-memory Info Prov DB +-- ---------------------------------------------------------------------------- + +type InfoProvMap = IntMap InfoProv + +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 diff --git a/src/GHC/Stack/Profiler/Speedscope/IpeDb.hs b/src/GHC/Stack/Profiler/Speedscope/IpeDb.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Speedscope/IpeDb.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module GHC.Stack.Profiler.Speedscope.IpeDb (toSpeedscopeInfoProv) where + +import qualified GHC.Stack.Profiler.Speedscope.Types as Speedscope +import qualified IpeDb.InfoProv as IpeDb + +toSpeedscopeInfoProv :: IpeDb.InfoProv -> Speedscope.InfoProv +toSpeedscopeInfoProv ipedb_info_prov = + Speedscope.InfoProv + { Speedscope.infoProvId = Speedscope.InfoProvId ipedb_info_prov.infoId.id + , Speedscope.infoProvSrcLoc = ipedb_info_prov.srcLoc + , Speedscope.infoProvModule = ipedb_info_prov.moduleName + , Speedscope.infoProvLabel = ipedb_info_prov.label + , Speedscope.infoTableName = ipedb_info_prov.tableName + , Speedscope.infoClosureDesc = fromIntegral ipedb_info_prov.closureDesc + , Speedscope.infoTyDesc = ipedb_info_prov.typeDesc + } diff --git a/src/GHC/Stack/Profiler/Speedscope/Options.hs b/src/GHC/Stack/Profiler/Speedscope/Options.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Speedscope/Options.hs @@ -0,0 +1,63 @@ +module GHC.Stack.Profiler.Speedscope.Options where + +import Data.Text (Text) +import Options.Applicative + +data SSOptions = SSOptions + { file :: FilePath + , isolateStart :: Maybe Text + , isolateEnd :: Maybe Text + , aggregationMode :: Aggregation + , ipeDbConf :: Maybe IpeConf + } + deriving (Show) + +data IpeConf = IpeConf + { file :: FilePath + , index :: Bool + } + deriving (Show) + +data Aggregation + = PerThread + | PerCapability + | NoAggregation + deriving (Show, Eq, Ord) + +options :: ParserInfo SSOptions +options = + info + (optsParser <**> helper) + ( fullDesc + <> progDesc "Generate a speedscope.app json file from an eventlog" + <> header "hs-speedscope" + ) + +optsParser :: Parser SSOptions +optsParser = + SSOptions + <$> argument str (metavar "FILE.eventlog") + <*> 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" + ) + ) + <*> 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 + ) + <*> optional ipeConfParser + +ipeConfParser :: Parser IpeConf +ipeConfParser = + IpeConf + <$> strOption (short 'f' <> long "ipedb" <> metavar "FILE" <> help "'ipedb' database location") + <*> flag False True (long "index" <> help "Create an index on-the-fly at the database location instead of in-memory database. Will overwrite any existing database.") diff --git a/src/GHC/Stack/Profiler/Speedscope/Types.hs b/src/GHC/Stack/Profiler/Speedscope/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Speedscope/Types.hs @@ -0,0 +1,40 @@ +module GHC.Stack.Profiler.Speedscope.Types where + +import Data.Text (Text) +import Data.Word (Word64) +import GHC.Stack.Profiler.Core.Eventlog (CapabilityId) +import GHC.Stack.Profiler.Core.SourceLocation (SourceLocation) + +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) + +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)