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
+-- := <ENTRY>+
+-- ENTRY
+-- := "01"
+-- | "02"
+-- | "03"
+-- CStringLen
+-- := <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.
