Hannes Siebenhandl pushed to branch wip/fendor/ghc-sample-profiler at Glasgow Haskell Compiler / GHC Commits: c5d76d58 by fendor at 2025-10-17T11:52:06+02:00 WIP: dont commit this, just for profiling - - - - - f3e2839a by Matthew Pickering at 2025-10-27T08:41:03+01:00 Verious stuff that needs to be revisited - - - - - 9 changed files: - .gitmodules - + ghc-debug - + ghc/GHC/EventLog/Sample.hs - ghc/Main.hs - ghc/ghc-bin.cabal.in - hadrian/src/Packages.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - + instructions.md Changes: ===================================== .gitmodules ===================================== @@ -118,3 +118,6 @@ [submodule "libraries/file-io"] path = libraries/file-io url = https://gitlab.haskell.org/ghc/packages/file-io.git +[submodule "ghc-debug"] + path = ghc-debug + url = git@gitlab.haskell.org:ghc/ghc-debug.git ===================================== ghc-debug ===================================== @@ -0,0 +1 @@ +Subproject commit 1b0f36fab86e9baa9734c88dcc1dbe17d10d8c93 ===================================== ghc/GHC/EventLog/Sample.hs ===================================== @@ -0,0 +1,376 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} + +module GHC.EventLog.Sample where +import Prelude + +import Control.Concurrent +import Control.Exception +import Control.Monad +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List as List +import GHC.Conc +import GHC.Conc.Sync + +import Control.Concurrent +import Control.Monad (replicateM, when) +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as BU +import qualified System.IO.Unsafe as Unsafe +import qualified Data.ByteString.Lazy as LBS +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Typeable (cast) +import Data.Maybe +import qualified Data.List.NonEmpty as NonEmpty +import Unsafe.Coerce +import GHC.Exts (Ptr(..), Int(..), traceBinaryEvent#) +import GHC.IO (IO(..)) +import GHC.Stack.Annotation.Experimental + +import GHC.Stack.CloneStack (StackSnapshot(..), cloneThreadStack) +import GHC.Internal.Conc.Sync + +import GHC.Internal.Conc.Sync +import GHC.Internal.InfoProv.Types (InfoProv(..), lookupIpProvId) +import GHC.Internal.Heap.Closures +import qualified GHC.Internal.Stack.Decode as Decode +import GHC.Internal.Stack.Types + +import Control.Monad (replicateM) +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get + +import GHC.Internal.RTS.Flags.Test + +import Debug.Trace +import GHC.Profiling.Eras + +traceBinaryEventIO :: B.ByteString -> IO () +traceBinaryEventIO bytes = traceBinaryEventIO' bytes + +traceBinaryEventIO' :: B.ByteString -> IO () +traceBinaryEventIO' bytes = + BU.unsafeUseAsCStringLen bytes $ \(Ptr p, I# n) -> IO $ \s -> + case traceBinaryEvent# p n s of + s' -> (# s', () #) + +data SamplerThread = MkSamplerThread + { samplerThreadId :: ThreadId + } deriving (Show, Eq, Ord) + +withSampleProfiler :: Int -> IO a -> IO a +withSampleProfiler delay act = do + enabled <- getUserEventTracingEnabled + if enabled + then bracket setupSamplers tearDownSamplers (const act) + else act + where + setupSamplers = do + samplerThreadConfigMVar <- newEmptyMVar + sid <- forkIO $ do + config <- takeMVar samplerThreadConfigMVar + sampleThreadId <- myThreadId + labelThread sampleThreadId "Sample Profiler Thread" + forever $ do + tids <- listThreads + userThreads <- filterM (isThreadOfInterest config) tids + forM_ userThreads $ \tid -> + sampleToEventlog tid + -- TODO: this is wrong, we don't sample every delay time as sampling takes time as well + threadDelay delay + + let sampleThreadConf = MkSamplerThread + { samplerThreadId = sid + } + putMVar samplerThreadConfigMVar sampleThreadConf + pure sampleThreadConf + + tearDownSamplers MkSamplerThread{samplerThreadId} = + killThread samplerThreadId + + isThreadOfInterest :: SamplerThread -> ThreadId -> IO Bool + isThreadOfInterest config tid = do + lbl <- threadLabel tid + pure $ not $ or + [ isProfilerThread config tid lbl + , isBuiltinThread tid lbl + ] + +isProfilerThread :: SamplerThread -> ThreadId -> Maybe String -> Bool +isProfilerThread MkSamplerThread {samplerThreadId} tid lbl = tid == samplerThreadId + +isBuiltinThread :: ThreadId -> Maybe String -> Bool +isBuiltinThread _ Nothing = False +isBuiltinThread _tid (Just lbl) = + lbl `elem` ["TimerManager"] || "IOManager on cap" `List.isPrefixOf` lbl + + +sampleToEventlog :: ThreadId -> IO () +sampleToEventlog tid = do + sampleThread tid >>= \ case + Nothing -> pure () + Just threadSample -> do + msg <- serializeThreadSample threadSample + traceBinaryEventIO $ LBS.toStrict msg + + +---- + + +newtype CapabilityId = + CapabilityId + { getCapabilityId :: Word64 + } + deriving (Show, Eq, Ord) + +data ThreadSample = + ThreadSample + { threadSampleId :: ThreadId + , threadSampleCapability :: CapabilityId + , threadSampleStackSnapshot :: StackSnapshot + } + +sampleThread :: ThreadId -> IO (Maybe ThreadSample) +sampleThread tid = do + (cap, blocked) <- threadCapability tid + if blocked + then pure Nothing + else do + stack <- cloneThreadStack tid + pure $ Just $ ThreadSample + { threadSampleId = tid + , threadSampleCapability = CapabilityId $ intToWord64 cap + , threadSampleStackSnapshot = stack + } + +serializeThreadSample :: ThreadSample -> IO LBS.ByteString +serializeThreadSample sample = do + callStackMessage <- threadSampleToCallStackMessage sample + pure $ runPut $ put callStackMessage + +deserializeCallStackMessage :: LBS.ByteString -> Either String CallStackMessage +deserializeCallStackMessage = Right . runGet get + +-- Message format: +-- +-- MESSAGE +-- := "CA" "11" <STACK> +-- STACK +-- := <capability: Word32> <threadId: Word32> <length: Word32> <ENTRY>+ +-- ENTRY +-- := "01" <ipe: Word64> +-- | "02" <string: STRING> +-- | "03" <row: Word32> <col: Word32> <function: CStringLen> <filename: CStringLen> +-- CStringLen +-- := <length: Word8> <Char>+ + +data CallStackMessage = + MkCallStackMessage + { callThreadId :: Word64 + , callCapabilityId :: CapabilityId + , callStack :: [StackItem] + } + deriving (Eq, Ord, Show) + +data StackItem + = IpeId !Word64 + | UserMessage !String + | SourceLocation !SourceLocation + deriving (Eq, Ord, Show) + +data SourceLocation = + MkSourceLocation + { line :: !Word32 + , column :: !Word32 + , functionName :: !Text + , fileName :: !Text + } + deriving (Eq, Ord, Show) + +instance Binary CallStackMessage where + put msg = do + putByteString "CA" + putByteString "11" + putWord32 $ word64ToWord32 $ getCapabilityId $ callCapabilityId msg + putWord32 $ word64ToWord32 $ callThreadId msg + putWord8 $ intToWord8 $ min cutOffLength $ length $ callStack msg -- TODO: limit number of stack entries to 2^32 + mapM_ put $ take cutOffLength $ callStack msg + + get = do + _ <- getByteString 2 -- CA + _ <- getByteString 2 -- 11 + capId <- getWord32 + tid <- getWord32 + len <- getWord8 + items <- replicateM (word8ToInt len) get + pure MkCallStackMessage + { callThreadId = word32ToWord64 tid + , callCapabilityId = CapabilityId $ word32ToWord64 capId + , callStack = items + } + +instance Binary SourceLocation where + put loc = do + putWord32 $ line loc + putWord32 $ column loc + putStringLen $ Text.unpack $ functionName loc + putStringLen $ Text.unpack $ fileName loc + + get = do + MkSourceLocation + <$> getWord32 + <*> getWord32 + <*> (Text.pack <$> getStringLen) + <*> (Text.pack <$> getStringLen) + +instance Binary StackItem where + put = \ case + IpeId ipeId -> do + putWord8 1 + putWord64 ipeId + UserMessage msg -> do + putWord8 2 + putStringLen msg + SourceLocation loc -> do + putWord8 3 + put loc + + get = do + getWord8 >>= \ case + 1 -> IpeId <$> getWord64 + 2 -> UserMessage <$> getStringLen + 3 -> SourceLocation <$> get + n -> fail $ "StackItem: Unexpected tag byte encounter: " <> show n + +decodeStackWithIpProvId :: StackSnapshot -> IO [(StackFrame, Maybe Word64)] +decodeStackWithIpProvId snapshot = do + concat . snd <$> Decode.decodeStackWithFrameUnpack unpackStackFrameWithIpProvId snapshot + +unpackStackFrameWithIpProvId :: Decode.StackFrameLocation -> IO (StackFrame, Maybe Word64) +unpackStackFrameWithIpProvId stackFrameLoc = do + Decode.unpackStackFrameTo stackFrameLoc + (\ info infoKey nextChunk@(StackSnapshot stack#) -> do + framesWithIpe <- decodeStackWithIpProvId nextChunk + mIpeId <- lookupIpProvId infoKey + pure + ( UnderflowFrame + { info_tbl = info, + nextChunk = + GenStgStackClosure + { ssc_info = info, + ssc_stack_size = Decode.getStackFields stack#, + ssc_stack = map fst framesWithIpe + } + } + , mIpeId + ) + + ) + (\ frame infoKey -> do + mIpeId <- lookupIpProvId infoKey + pure (frame, mIpeId) + ) + +threadSampleToCallStackMessage :: ThreadSample -> IO CallStackMessage +threadSampleToCallStackMessage sample = do + frames <- decodeStackWithIpProvId $ threadSampleStackSnapshot sample + let stackMessages = fmap List.head . List.group $ mapMaybe (uncurry stackFrameToStackItem) frames + pure MkCallStackMessage + { callThreadId = fromThreadId $ threadSampleId sample + , callCapabilityId = threadSampleCapability sample + , callStack = stackMessages + } + +stackFrameToStackItem :: StackFrame -> Maybe Word64 -> Maybe StackItem +stackFrameToStackItem frame mIpe = + case frame of + AnnFrame { annotation = Box someStackAnno } -> + case unsafeCoerce someStackAnno of + SomeStackAnnotation ann -> + case cast ann of + Just (CallStackAnnotation cs) -> + case getCallStack cs of + [] -> Nothing + ((name, sourceLoc):_) -> + Just $ SourceLocation $ MkSourceLocation + { line = intToWord32 $ srcLocStartLine sourceLoc + , column = intToWord32 $ srcLocStartCol sourceLoc + , functionName = Text.pack $ name + , fileName = Text.pack $ srcLocFile sourceLoc + } + + Nothing -> case cast ann of + Just (StringAnnotation msg) -> + Just $ UserMessage msg + Nothing -> + Nothing + _ -> + IpeId <$> mIpe + +-------- + +cutOffLength :: Int +cutOffLength = 255 + +putStringLenWithTag :: Word8 -> String -> Put +putStringLenWithTag tag msg = + putWord8 tag <> putStringLen msg + +putStringLen :: String -> Put +putStringLen msg = + putWord8 len <> putStringUtf8 msg + where + shortName = take cutOffLength msg + -- this is safe as we made sure that cutOffLength fits in a Word8 + len = intToWord8 $ length shortName + +getStringLen :: Get String +getStringLen = do + len <- getWord8 + replicateM (word8ToInt len) get + +putWord64 :: Word64 -> Put +putWord64 = putWord64be + +putWord32 :: Word32 -> Put +putWord32 = putWord32be + +getWord64 :: Get Word64 +getWord64 = getWord64be + +getWord32 :: Get Word32 +getWord32 = getWord32be + +word64ToWord32 :: Word64 -> Word32 +word64ToWord32 = fromIntegral + +word32ToWord64 :: Word32 -> Word64 +word32ToWord64 = fromIntegral + +word32ToInt :: Word32 -> Int +word32ToInt = fromIntegral + +word64ToInt :: Word64 -> Int +word64ToInt = fromIntegral + +intToWord64 :: Int -> Word64 +intToWord64 = fromIntegral + +intToWord32 :: Int -> Word32 +intToWord32 = fromIntegral + +intToWord8 :: Int -> Word8 +intToWord8 = fromIntegral + +word8ToInt :: Word8 -> Int +word8ToInt = fromIntegral + ===================================== ghc/Main.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Driver.Backpack ( doBackpack ) import GHC.Driver.Plugins import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Config.Diagnostic +import GHC.Driver.Monad import GHC.Platform import GHC.Platform.Host @@ -92,6 +93,14 @@ import Data.List ( isPrefixOf, partition, intercalate ) import Prelude import qualified Data.List.NonEmpty as NE +#if defined(GHC_DEBUG) +import GHC.Debug.Stub +#endif + +#if defined(SAMPLE_TRACER) +import GHC.EventLog.Sample +#endif + ----------------------------------------------------------------------------- -- ToDo: @@ -104,8 +113,24 @@ import qualified Data.List.NonEmpty as NE ----------------------------------------------------------------------------- -- GHC's command-line interface +withGhcSampleProfiler :: IO () -> IO () +#if defined(SAMPLE_TRACER) +withGhcSampleProfiler = + withSampleProfiler 10000 +#else +withGhcSampleProfiler = + id +#endif + +debugWrapper :: IO a -> IO a +#if defined(GHC_DEBUG) +debugWrapper = withGhcDebug +#else +debugWrapper = id +#endif + main :: IO () -main = do +main = withGhcSampleProfiler $ do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering @@ -152,8 +177,10 @@ main = do ShowGhcUsage -> showGhcUsage dflags ShowGhciUsage -> showGhciUsage dflags PrintWithDynFlags f -> putStrLn (f dflags) - Right postLoadMode -> - main' postLoadMode units dflags argv3 flagWarnings + Right postLoadMode -> do + reifyGhc $ \session -> debugWrapper $ + reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session + main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn] -> Ghc () ===================================== ghc/ghc-bin.cabal.in ===================================== @@ -22,11 +22,21 @@ Flag internal-interpreter Default: False Manual: True +Flag ghc-debug + Description: Build with support for ghc-debug. + Default: False + Manual: True + Flag threaded Description: Link the ghc executable against the threaded RTS Default: True Manual: True +Flag sampleTracer + Description: Link the ghc executable against the threaded RTS + Default: False + Manual: True + Executable ghc Default-Language: GHC2021 @@ -42,9 +52,20 @@ Executable ghc filepath >= 1.5 && < 1.6, containers >= 0.5 && < 0.9, transformers >= 0.5 && < 0.7, + ghc-internal, ghc-experimental, binary, + text, ghc-boot == @ProjectVersionMunged@, ghc == @ProjectVersionMunged@ + if flag(sampleTracer) + CPP-OPTIONS: -DSAMPLE_TRACER + other-modules: + GHC.EventLog.Sample + + if flag(ghc-debug) + build-depends: ghc-debug-stub + CPP-OPTIONS: -DGHC_DEBUG + if os(windows) Build-Depends: Win32 >= 2.3 && < 2.15 else ===================================== hadrian/src/Packages.hs ===================================== @@ -12,7 +12,7 @@ module Packages ( runGhc, semaphoreCompat, stm, templateHaskell, terminfo, text, time, timeout, transformers, unlit, unix, win32, xhtml, lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, - ghcPackages, isGhcPackage, + ghcPackages, isGhcPackage, ghc_debug_convention, ghc_debug_stub, -- * Package information crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath, @@ -43,7 +43,9 @@ ghcPackages = , terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio , timeout , lintersCommon - , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ] + , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace + , ghc_debug_convention + , ghc_debug_stub ] -- TODO: Optimise by switching to sets of packages. isGhcPackage :: Package -> Bool @@ -133,6 +135,8 @@ unlit = util "unlit" unix = lib "unix" win32 = lib "Win32" xhtml = lib "xhtml" +ghc_debug_convention = lib "ghc-debug-convention" `setPath` "ghc-debug/convention" +ghc_debug_stub = lib "ghc-debug-stub" `setPath` "ghc-debug/stub" lintersCommon = lib "linters-common" `setPath` "linters/linters-common" lintNotes = linter "lint-notes" ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -174,6 +174,8 @@ stage1Packages = do , unlit , xhtml , if winTarget then win32 else unix + , ghc_debug_convention + , ghc_debug_stub ] , when (not cross) [ hpcBin ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -116,6 +116,7 @@ packageArgs = do , builder (Cabal Flags) ? mconcat [ (expr (ghcWithInterpreter stage)) `cabalFlag` "internal-interpreter" + , notStage0 `cabalFlag` "ghc-debug" , ifM stage0 -- We build a threaded stage 1 if the bootstrapping compiler -- supports it. @@ -124,6 +125,7 @@ packageArgs = do -- We build a threaded stage N, N>1 if the configuration calls -- for it. (compilerStageOption ghcThreaded `cabalFlag` "threaded") + , notStage0 `cabalFlag` "sampleTracer" ] ] ===================================== instructions.md ===================================== @@ -0,0 +1,45 @@ +# Building GHC + +* Add the following to _build/hadrian.settings + +``` +stage1.*.ghc.hs.opts += -finfo-table-map -fdistinct-constructor-tables +``` + +* Build GHC as normal + +``` +./hadrian/build -j8 +``` + +* The result is a ghc-debug enabled compiler + +# Building a debugger + +* Use the compiler you just built to build ghc-debug + +``` +cd ghc-debug +cabal update +cabal new-build debugger -w ../_build/stage1/bin/ghc +``` + +# Running the debugger + +Modify `test/Test.hs` to implement the debugging thing you want to do. Perhaps +start with `p30`, which is a program to generate a profile. + + +* Start the process you want to debug +``` +GHC_DEBUG_SOCKET=/tmp/ghc-debug build-cabal +``` + +* Start the debugger +``` +cabal new-run debugger -w ... +``` + +* Open a ticket about the memory issue you find. + + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/67ea2dcc1582dc863c8c8e3a6af9657... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/67ea2dcc1582dc863c8c8e3a6af9657... You're receiving this email because of your account on gitlab.haskell.org.