Hannes Siebenhandl pushed to branch wip/fendor/ghc-sample-profiler at Glasgow Haskell Compiler / GHC Commits: 3ff55063 by fendor at 2025-10-29T15:51:02+01:00 Expose more stack decoding details - - - - - 7d53eed9 by fendor at 2025-10-29T16:13:07+01:00 Sample Profiler commit - - - - - 10 changed files: - .gitmodules - + eventlog-live-profiling-prototype - ghc/Main.hs - ghc/ghc-bin.cabal.in - hadrian/src/Packages.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghci/GHCi/Message.hs Changes: ===================================== .gitmodules ===================================== @@ -124,3 +124,6 @@ [submodule "libraries/template-haskell-quasiquoter"] path = libraries/template-haskell-quasiquoter url = https://gitlab.haskell.org/ghc/template-haskell-quasiquoter.git +[submodule "eventlog-live-profiling-prototype"] + path = eventlog-live-profiling-prototype + url = git@gitlab.well-typed.com:well-typed/eventlog-live-profiling-prototype.git ===================================== eventlog-live-profiling-prototype ===================================== @@ -0,0 +1 @@ +Subproject commit 4ebbfbfffd3dd255a661414b5d7c9a990ff4f4fc ===================================== ghc/Main.hs ===================================== @@ -80,6 +80,7 @@ import GHC.Iface.Errors.Ppr import GHC.Driver.Session.Mode import GHC.Driver.Session.Lint import GHC.Driver.Session.Units +import GHC.Driver.Monad -- Standard Haskell libraries import System.IO @@ -91,6 +92,17 @@ import Control.Monad.Trans.Except (throwE, runExceptT) import Data.List ( isPrefixOf, partition, intercalate ) import Prelude import qualified Data.List.NonEmpty as NE +#if defined(SAMPLE_TRACER) +import Sampler +#endif + +runWithSampleProfiler :: IO () -> IO () +runWithSampleProfiler = +#if defined(SAMPLE_TRACER) + withSampleProfiler 10000 {- Every 10 ms -} +#else + id +#endif ----------------------------------------------------------------------------- -- ToDo: @@ -153,7 +165,8 @@ main = do ShowGhciUsage -> showGhciUsage dflags PrintWithDynFlags f -> putStrLn (f dflags) Right postLoadMode -> - main' postLoadMode units dflags argv3 flagWarnings + reifyGhc $ \session -> runWithSampleProfiler $ + reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn] -> Ghc () ===================================== ghc/ghc-bin.cabal.in ===================================== @@ -27,6 +27,11 @@ Flag threaded Default: True Manual: True +Flag sampleTracer + Description: Whether we instrument the ghc binary with sample tracer when the eventlog is enabled + Default: False + Manual: True + Executable ghc Default-Language: GHC2021 @@ -45,6 +50,10 @@ Executable ghc ghc-boot == @ProjectVersionMunged@, ghc == @ProjectVersionMunged@ + if flag(sampleTracer) + build-depends: ghc-sampler-eventlog + CPP-OPTIONS: -DSAMPLE_TRACER + if os(windows) Build-Depends: Win32 >= 2.3 && < 2.15 else ===================================== hadrian/src/Packages.hs ===================================== @@ -13,6 +13,7 @@ module Packages ( transformers, unlit, unix, win32, xhtml, lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, ghcPackages, isGhcPackage, + ghc_sampler_eventlog, -- * Package information crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath, @@ -43,7 +44,8 @@ ghcPackages = , terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio , timeout , lintersCommon - , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ] + , ghc_sampler_eventlog + ] -- TODO: Optimise by switching to sets of packages. isGhcPackage :: Package -> Bool @@ -135,6 +137,7 @@ unlit = util "unlit" unix = lib "unix" win32 = lib "Win32" xhtml = lib "xhtml" +ghc_sampler_eventlog = lib "ghc-sampler-eventlog" `setPath` "eventlog-live-profiling-prototype/sampler" lintersCommon = lib "linters-common" `setPath` "linters/linters-common" lintNotes = linter "lint-notes" ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -180,6 +180,7 @@ stage1Packages = do , unlit , xhtml , if winTarget then win32 else unix + , ghc_sampler_eventlog ] , when (not cross) [ hpcBin ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -108,6 +108,12 @@ packageArgs = do , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ] + , package ghc_sampler_eventlog ? mconcat + [ builder (Cabal Flags) ? mconcat + [ arg "-use-ghc-trace-events" + ] + ] + ---------------------------------- ghc --------------------------------- , package ghc ? mconcat [ builder Ghc ? mconcat ===================================== libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc ===================================== @@ -15,12 +15,13 @@ module GHC.Internal.InfoProv.Types , getIPE , StgInfoTable , lookupIPE + , lookupIpProvId ) where import GHC.Internal.Base import GHC.Internal.Enum import GHC.Internal.Real (fromIntegral) -import GHC.Internal.Word (Word32) +import GHC.Internal.Word (Word32, Word64) import GHC.Internal.Show (Show) import GHC.Internal.Ptr (Ptr(..), plusPtr) import GHC.Internal.Foreign.C.String.Encoding (CString, peekCString) @@ -32,6 +33,7 @@ import GHC.Internal.ClosureTypes import GHC.Internal.Prim (whereFrom##) data InfoProv = InfoProv { + ipProvId :: Word64, ipName :: String, ipDesc :: ClosureType, ipTyDesc :: String, @@ -59,6 +61,13 @@ lookupIPE itbl = allocaBytes (#size InfoProvEnt) $ \p -> do 1 -> Just `fmap` peekInfoProv (ipeProv p) _ -> return Nothing +lookupIpProvId :: Ptr StgInfoTable -> IO (Maybe Word64) +lookupIpProvId itbl = allocaBytes (#size InfoProvEnt) $ \p -> do + res <- c_lookupIPE itbl p + case res of + 1 -> Just `fmap` peekIpProvId (ipeProv p) + _ -> return Nothing + getIPE :: a -> r -> (Ptr InfoProvEnt -> IO r) -> IO r getIPE obj fail k = allocaBytes (#size InfoProvEnt) $ \p -> IO $ \s -> case whereFrom## obj (unPtr p) s of @@ -73,6 +82,9 @@ ipeProv p = (#ptr InfoProvEnt, prov) p peekIpDesc :: Ptr InfoProv -> IO Word32 peekIpDesc p = (# peek InfoProv, closure_desc) p +peekIpProvId :: Ptr InfoProv -> IO Word64 +peekIpProvId p = (# peek InfoProv, info_prov_id) p + peekIpName, peekIpLabel, peekIpUnitId, peekIpModule, peekIpSrcFile, peekIpSrcSpan, peekIpTyDesc :: Ptr InfoProv -> IO CString peekIpName p = (# peek InfoProv, table_name) p peekIpLabel p = (# peek InfoProv, label) p @@ -84,6 +96,7 @@ peekIpTyDesc p = (# peek InfoProv, ty_desc) p peekInfoProv :: Ptr InfoProv -> IO InfoProv peekInfoProv infop = do + provId <- peekIpProvId infop name <- peekCString utf8 =<< peekIpName infop desc <- peekIpDesc infop tyDesc <- peekCString utf8 =<< peekIpTyDesc infop @@ -93,6 +106,7 @@ peekInfoProv infop = do file <- peekCString utf8 =<< peekIpSrcFile infop span <- peekCString utf8 =<< peekIpSrcSpan infop return InfoProv { + ipProvId = provId, ipName = name, -- The INVALID_OBJECT case should be impossible as we -- control the C code generating these values. ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -25,6 +25,10 @@ module GHC.Internal.Stack.Decode ( -- * Pretty printing prettyStackEntry, prettyStackFrameWithIpe, + -- * Low level decoding functions + StackFrameLocation(..), + unpackStackFrameTo, + getStackFields, ) where @@ -69,6 +73,7 @@ import GHC.Internal.Stack.ConstantsProf () #endif import GHC.Internal.Stack.CloneStack import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE) +import qualified GHC.Internal.InfoProv.Types as IPE {- Note [Decoding the stack] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -186,11 +191,11 @@ foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSna -- | Get the 'StgInfoTable' of the stack frame. -- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any. -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv) +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Ptr IPE.StgInfoTable) getInfoTableOnStack stackSnapshot# index = let !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) in - (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr_ipe_key#) + (,) <$> peekItbl (Ptr itbl_struct#) <*> pure (Ptr itbl_ptr_ipe_key#) getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable getInfoTableForStack stackSnapshot# = @@ -324,8 +329,9 @@ unpackStackFrame stackFrameLoc = do unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)] unpackStackFrameWithIpe stackFrameLoc = do unpackStackFrameTo stackFrameLoc - (\ info mIpe nextChunk@(StackSnapshot stack#) -> do + (\ info infoKey nextChunk@(StackSnapshot stack#) -> do framesWithIpe <- decodeStackWithIpe nextChunk + mIpe <- lookupIPE infoKey pure [ ( UnderflowFrame { info_tbl = info, @@ -340,22 +346,26 @@ unpackStackFrameWithIpe stackFrameLoc = do ) ] ) - (\ frame mIpe -> pure [(frame, mIpe)]) + (\ frame infoKey -> do + mIpe <- lookupIPE infoKey + pure [(frame, mIpe)]) unpackStackFrameTo :: forall a . StackFrameLocation -> -- ^ Decode the given 'StackFrame'. - (StgInfoTable -> Maybe InfoProv -> StackSnapshot -> IO a) -> + (StgInfoTable -> Ptr IPE.StgInfoTable -> StackSnapshot -> IO a) -> -- ^ How to handle 'UNDERFLOW_FRAME's. - (StackFrame -> Maybe InfoProv -> IO a) -> + -- The pointer is the key for the 'lookupIPE'. + (StackFrame -> Ptr IPE.StgInfoTable -> IO a) -> -- ^ How to handle all other 'StackFrame' values. + -- The pointer is the key for the 'lookupIPE'. IO a unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do - (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index + (info, infoTablePtr) <- getInfoTableOnStack stackSnapshot# index unpackStackFrame' info - (unpackUnderflowFrame info m_info_prov) - (`finaliseStackFrame` m_info_prov) + (unpackUnderflowFrame info infoTablePtr) + (`finaliseStackFrame` infoTablePtr) where unpackStackFrame' :: StgInfoTable -> ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -545,7 +545,11 @@ instance Binary Heap.ClosureType instance Binary Heap.PrimType instance Binary a => Binary (Heap.GenClosure a) instance Binary InfoProv where -#if MIN_VERSION_base(4,20,0) +#if MIN_VERSION_base(4,22,0) + get = InfoProv <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get + put (InfoProv x1 x2 x3 x4 x5 x6 x7 x8 x9) + = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 >> put x8 >> put x9 +#elif MIN_VERSION_base(4,20,0) get = InfoProv <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get put (InfoProv x1 x2 x3 x4 x5 x6 x7 x8) = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 >> put x8 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fcf56eb3f0e03291e86b71f6979e874... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fcf56eb3f0e03291e86b71f6979e874... You're receiving this email because of your account on gitlab.haskell.org.