packages feed

ghc-stack-profiler-speedscope 0.1.0.0 → 0.2.0.0

raw patch · 6 files changed

+397/−192 lines, 6 filesdep +ipedbdep ~ghc-stack-profiler-core

Dependencies added: ipedb

Dependency ranges changed: ghc-stack-profiler-core

Files

CHANGELOG.md view
@@ -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.
ghc-stack-profiler-speedscope.cabal view
@@ -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
src/GHC/Stack/Profiler/Speedscope.hs view
@@ -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
+ src/GHC/Stack/Profiler/Speedscope/IpeDb.hs view
@@ -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+    }
+ src/GHC/Stack/Profiler/Speedscope/Options.hs view
@@ -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.")
+ src/GHC/Stack/Profiler/Speedscope/Types.hs view
@@ -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)