diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Revision history for ghc-stack-profiler +## 0.2.0.0 -- 2026-04-10 + +* Backport stack decoding segmentation fault fix from GHC HEAD [#20](https://github.com/well-typed/ghc-stack-profiler/pull/20) +* Add support for eventlog-socket lifecycle hooks [#19](https://github.com/well-typed/ghc-stack-profiler/pull/19) +* Never crash on decoding errors [#12](https://github.com/well-typed/ghc-stack-profiler/pull/12) +* Use aync for proper thread management [#10](https://github.com/well-typed/ghc-stack-profiler/pull/10) +* Implement support for eventlog-socket and custom commands [#7](https://github.com/well-typed/ghc-stack-profiler/pull/7) + ## 0.1.0.0 -- 2025-12-09 * Adds API for sampling the RTS callstack and writing the results to the eventlog. diff --git a/cbits/Stack.cmm b/cbits/Stack.cmm --- a/cbits/Stack.cmm +++ b/cbits/Stack.cmm @@ -17,9 +17,11 @@ // developed. #if defined(StgStack_marking) -// Returns the next stackframe's StgStack* and offset in it. And, an indicator -// if this frame is the last one (`hasNext` bit.) -// (StgStack*, StgWord, StgWord) advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords) +// Returns the next stackframe location as +// (# (# #) | (# StgStack*, StgWord #) #) +// flattened to its runtime representation: +// (tag, StgStack*, StgWord) +// where tag 1 means no next frame and tag 2 means the payload is present. advanceStackFrameLocationzh (P_ stack, W_ offsetWords) { W_ frameSize; (frameSize) = ccall stackFrameSize(stack, offsetWords); @@ -36,27 +38,30 @@ stackSizeInBytes = WDS(stackSize); stackBottom = stackSizeInBytes + stackArrayPtr; + W_ tag, newOffsetWords; P_ newStack; - W_ newOffsetWords, hasNext; if(nextClosurePtr < stackBottom) (likely: True) { + tag = 2; newStack = stack; newOffsetWords = offsetWords + frameSize; - hasNext = 1; } else { P_ underflowFrameStack; (underflowFrameStack) = ccall getUnderflowFrameStack(stack, offsetWords); if (underflowFrameStack == NULL) (likely: True) { - newStack = NULL; - newOffsetWords = NULL; - hasNext = NULL; + // The empty alternative still has dead payload slots in the flattened + // sum representation, so the pointer field must contain a valid closure + // pointer rather than NULL. + tag = 1; + newStack = stack; + newOffsetWords = 0; } else { + tag = 2; newStack = underflowFrameStack; - newOffsetWords = NULL; - hasNext = 1; + newOffsetWords = 0; } } - return (newStack, newOffsetWords, hasNext); + return (tag, newStack, newOffsetWords); } // (StgWord, StgWord) getSmallBitmapzh(StgStack* stack, StgWord offsetWords) diff --git a/ghc-stack-profiler.cabal b/ghc-stack-profiler.cabal --- a/ghc-stack-profiler.cabal +++ b/ghc-stack-profiler.cabal @@ -1,6 +1,6 @@ cabal-version: 3.8 name: ghc-stack-profiler -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 @@ -53,7 +53,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: @@ -67,9 +70,12 @@ DuplicateRecordFields LambdaCase NamedFieldPuns + NoImportQualifiedPost PatternSynonyms ViewPatterns + default-language: GHC2021 + flag use-ghc-trace-events description: Use the package 'ghc-trace-events'. Disabling this flag makes it much easier to use @ghc-stack-profiler@ on the @ghc@ codebase, as @@ -78,6 +84,13 @@ manual: True default: True +flag control + description: + Enable @eventlog-socket@ control commands. + + manual: True + default: False + library import: warnings, exts @@ -90,21 +103,31 @@ GHC.Internal.Stack.Constants.Compat GHC.Internal.Stack.Decode.Compat GHC.Stack.Annotation.Experimental.Compat + GHC.Stack.Profiler + GHC.Stack.Profiler.Commands GHC.Stack.Profiler.Decode - GHC.Stack.Profiler.Sampler + GHC.Stack.Profiler.FFI + GHC.Stack.Profiler.Manager GHC.Stack.Profiler.Stack.Compat GHC.Stack.Profiler.Stack.Decode + GHC.Stack.Profiler.SymbolTable GHC.Stack.Profiler.Util build-depends: + async >=2.2 && <2.2.6, base >=4.20 && <4.23, binary >=0.8.9.3 && <0.11, bytestring >=0.11 && <0.13, + containers >=0.6.8 && <0.9, ghc-heap >=9.10.1 && <9.16, ghc-internal >=9.1001 && <9.1600, - ghc-stack-profiler-core ^>=0.1, + ghc-stack-profiler-core ==0.2.0.0, + stm ^>=2.5.3.0 || ^>=2.5.0.0, text >=2 && <2.2, + hs-source-dirs: + src + if impl(ghc >=9.14) build-depends: ghc-experimental >=9.1400 && <9.1600 @@ -116,15 +139,27 @@ ghc-trace-events ^>=0.1.2.10 else build-depends: - ghc-prim + ghc-prim >=0.6.0 && <1 - if impl(ghc <9.14) + -- Custom stack decoding for GHC <9.14.2 + -- Fixes https://github.com/well-typed/ghc-stack-profiler/issues/14 + -- See https://gitlab.haskell.org/ghc/ghc/-/issues/27009 for the fix. + if impl(ghc <9.14.2) cmm-sources: cbits/Stack.cmm c-sources: cbits/Stack_c.c - hs-source-dirs: - src - default-language: GHC2021 + -- eventlog-socket custom command support + if flag(control) && !os(windows) + cpp-options: + -DEVENTLOG_SOCKET_SUPPORT + + build-depends: + eventlog-socket ^>=0.1.3 + +source-repository head + type: git + location: https://github.com/well-typed/ghc-stack-profiler.git + subdir: ghc-stack-profiler diff --git a/src/Debug/Trace/Binary/Compat.hs b/src/Debug/Trace/Binary/Compat.hs --- a/src/Debug/Trace/Binary/Compat.hs +++ b/src/Debug/Trace/Binary/Compat.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} + module Debug.Trace.Binary.Compat ( -- * For tracing user binary events traceBinaryEventIO, + -- * Flag to check whether the eventlog is enabled - userTracingEnabled, - ) where + userTracingEnabledIO, +) where #if defined(USE_GHC_TRACE_EVENTS) import Debug.Trace.Binary (traceBinaryEventIO) @@ -18,7 +20,12 @@ import GHC.Exts (Ptr(..), Int(..), traceBinaryEvent#) import GHC.Internal.RTS.Flags.Test (getUserEventTracingEnabled) import System.IO.Unsafe (unsafePerformIO) +#endif +#if defined(USE_GHC_TRACE_EVENTS) +userTracingEnabledIO :: IO Bool +userTracingEnabledIO = pure userTracingEnabled +#else traceBinaryEventIO :: B.ByteString -> IO () traceBinaryEventIO bytes = traceBinaryEventIO' bytes @@ -28,6 +35,6 @@ case traceBinaryEvent# p n s of s' -> (# s', () #) -userTracingEnabled :: Bool -userTracingEnabled = unsafePerformIO getUserEventTracingEnabled +userTracingEnabledIO :: IO Bool +userTracingEnabledIO = getUserEventTracingEnabled #endif diff --git a/src/GHC/Internal/Heap/Closures/Compat.hs b/src/GHC/Internal/Heap/Closures/Compat.hs --- a/src/GHC/Internal/Heap/Closures/Compat.hs +++ b/src/GHC/Internal/Heap/Closures/Compat.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} + module GHC.Internal.Heap.Closures.Compat ( - Box(..), + Box (..), ) where #if MIN_VERSION_ghc_internal(9,1400,0) diff --git a/src/GHC/Internal/Stack/Constants/Compat.hs b/src/GHC/Internal/Stack/Constants/Compat.hs --- a/src/GHC/Internal/Stack/Constants/Compat.hs +++ b/src/GHC/Internal/Stack/Constants/Compat.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} + module GHC.Internal.Stack.Constants.Compat ( - WordOffset(..), + WordOffset (..), offsetStgAnnFrameAnn, ) where @@ -16,4 +17,3 @@ offsetStgAnnFrameAnn :: WordOffset offsetStgAnnFrameAnn = error "offsetStgAnnFrameAnn is only available in GHC >=9.14" #endif - diff --git a/src/GHC/Internal/Stack/Decode/Compat.hs b/src/GHC/Internal/Stack/Decode/Compat.hs --- a/src/GHC/Internal/Stack/Decode/Compat.hs +++ b/src/GHC/Internal/Stack/Decode/Compat.hs @@ -1,30 +1,33 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedSums #-} {-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE CPP #-} + module GHC.Internal.Stack.Decode.Compat ( StackFrameLocation, StackSnapshot#, - StackInfoTable(..), + StackInfoTable (..), getInfoTableForStack, getInfoTableOnStack, advanceStackFrameLocation, stackHead, - Box(..), + Box (..), getClosureBox, ) where import GHC.Exts import GHC.Stack.CloneStack (StackSnapshot (..)) + -- See Note [No way-dependent imports] #if defined(PROFILING) import GHC.Exts.Heap.InfoTableProf #else import GHC.Exts.Heap.InfoTable #endif -import qualified GHC.Internal.InfoProv.Types as InfoProv import GHC.Internal.Heap.Closures.Compat +import qualified GHC.Internal.InfoProv.Types as InfoProv import GHC.Internal.Stack.Constants.Compat (WordOffset) {- @@ -52,16 +55,18 @@ -- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any. getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StackInfoTable getInfoTableOnStack stackSnapshot# index = do - let !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) - itbl_struct = Ptr itbl_struct# - itbl_ptr = Ptr itbl_ptr_ipe_key# + let + !(# itbl_struct#, itbl_ptr_ipe_key# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) + itbl_struct = Ptr itbl_struct# + itbl_ptr = Ptr itbl_ptr_ipe_key# itbl <- peekItbl itbl_struct - pure StackInfoTable - { infoTableStructPtr = itbl_struct - , infoTablePtr = itbl_ptr - , infoTable = itbl - } + pure + StackInfoTable + { infoTableStructPtr = itbl_struct + , infoTablePtr = itbl_ptr + , infoTable = itbl + } getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable getInfoTableForStack stackSnapshot# = @@ -70,14 +75,15 @@ -- | Advance to the next stack frame (if any) advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation -advanceStackFrameLocation (StackSnapshot stackSnapshot#, index) = - let !(# s', i', hasNext #) = advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index) - in if I# hasNext > 0 - then Just (StackSnapshot s', primWordToWordOffset i') - else Nothing - where - primWordToWordOffset :: Word# -> WordOffset - primWordToWordOffset w# = fromIntegral (W# w#) +advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) = + case advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index) of + (# (# #) | #) -> + Nothing + (# | (# s', i' #) #) -> + Just (StackSnapshot s', primWordToWordOffset i') + where + primWordToWordOffset :: Word# -> WordOffset + primWordToWordOffset w# = fromIntegral (W# w#) -- | `StackFrameLocation` of the top-most stack frame stackHead :: StackSnapshot# -> StackFrameLocation @@ -95,7 +101,7 @@ -- The last `Int#` in the result tuple is meant to be treated as bool -- (has_next). foreign import prim "advanceStackFrameLocationzh" - advanceStackFrameLocation# :: StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #) + advanceStackFrameLocation# :: StackSnapshot# -> Word# -> (# (# #) | (# StackSnapshot#, Word# #) #) foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #) @@ -104,7 +110,7 @@ getStackInfoTableAddr# :: StackSnapshot# -> Addr# foreign import prim "getStackClosurezh" - getStackClosure# :: StackSnapshot# -> Word# -> Any + getStackClosure# :: StackSnapshot# -> Word# -> Any -- ---------------------------------------------------------------------------- -- Utilities that really should live somewhere else diff --git a/src/GHC/Stack/Annotation/Experimental/Compat.hs b/src/GHC/Stack/Annotation/Experimental/Compat.hs --- a/src/GHC/Stack/Annotation/Experimental/Compat.hs +++ b/src/GHC/Stack/Annotation/Experimental/Compat.hs @@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} + module GHC.Stack.Annotation.Experimental.Compat ( - SomeStackAnnotation(..), - CallStackAnnotation(..), - StringAnnotation(..), + SomeStackAnnotation (..), + CallStackAnnotation (..), + StringAnnotation (..), ) where #if MIN_VERSION_ghc_internal(9,1400,0) diff --git a/src/GHC/Stack/Profiler.hs b/src/GHC/Stack/Profiler.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler.hs @@ -0,0 +1,393 @@ +module GHC.Stack.Profiler ( + -- * Run sample profiler + withStackProfiler, + withStackProfilerForMyThread, + withStackProfilerForThread, + withRootStackProfiler, + shutdownStackProfilerManager, + + -- * Configuration of sample profiler + StackProfilerManager (..), + ProfilerSamplingInterval (..), + + -- * Basic thread sampler + sampleThread, + + -- * Low level helpers for setting up custom sample profilers threads + runWithStackProfiler, + setupStackProfilerThread, + stopStackProfilerThread, + + -- * Thread filtering + isProfilerThread, + isRtsThread, +) where + +import GHC.Conc +import GHC.Conc.Sync (fromThreadId, threadLabel) +import GHC.Stack.CloneStack (cloneThreadStack) + +import Control.Concurrent +import Control.Concurrent.Async +import qualified Control.Concurrent.Chan as Chan +import qualified Control.Concurrent.STM.TVar as STM +import Control.Exception +import Control.Monad +import qualified Control.Monad.STM as STM +import qualified Data.ByteString.Lazy as LBS +import Data.Foldable (traverse_) +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Debug.Trace +import qualified Debug.Trace.Binary.Compat as Compat + +import GHC.Stack.Profiler.Commands (sendStopProfilingMessage) +import GHC.Stack.Profiler.Core.Eventlog +import GHC.Stack.Profiler.Core.ThreadSample +import GHC.Stack.Profiler.Core.Util +import GHC.Stack.Profiler.Decode +import qualified GHC.Stack.Profiler.Decode as Decode +import qualified GHC.Stack.Profiler.FFI as FFI +import GHC.Stack.Profiler.Manager +import GHC.Stack.Profiler.SymbolTable (readSymbolTable) + +-- | Sampling intervals for the stack profiler. +data ProfilerSamplingInterval + = -- | Sample every @n@ milliseconds. + -- + -- Recommended value: @'SampleIntervalMs' 10@ or @'SampleIntervalMs' 20@. + SampleIntervalMs Int + deriving (Show, Eq, Ord) + +profilerSamplingIntervalToThreadDelayTime :: ProfilerSamplingInterval -> Int +profilerSamplingIntervalToThreadDelayTime = \case + SampleIntervalMs n -> n * 1000 + +-- ---------------------------------------------------------------------------- +-- High-Level user API +-- ---------------------------------------------------------------------------- + +-- | Sample the all non-rts threads every 'ProfilerSamplingInterval' for the duration of +-- the wrapped action. +-- Once the wrapped action terminates, the stack profiling stops. +-- +-- RTS threads such as the 'TimerManager' and 'IOManager' are not sampled as these +-- are usually not interesting for user code. +withStackProfiler :: StackProfilerManager -> ProfilerSamplingInterval -> IO a -> IO a +withStackProfiler manager delay act = do + runWithStackProfiler + manager + (allThreadSampler manager delay) + (defaultCallStackSerialiser manager) + act + +-- | Sample the current thread every 'ProfilerSamplingInterval' for the duration of +-- the wrapped action. +-- Once the wrapped action terminates, the stack profiling stops. +withStackProfilerForMyThread :: StackProfilerManager -> ProfilerSamplingInterval -> IO a -> IO a +withStackProfilerForMyThread manager delay act = do + tid <- myThreadId + withStackProfilerForThread manager tid delay act + +-- | Sample a specific 'ThreadId' every 'ProfilerSamplingInterval' for the duration of +-- the wrapped action. +-- Once the wrapped action terminates, the stack profiling stops. +withStackProfilerForThread :: StackProfilerManager -> ThreadId -> ProfilerSamplingInterval -> IO a -> IO a +withStackProfilerForThread manager tid delay act = + runWithStackProfiler + manager + (singleThreadSampler manager delay tid) + (defaultCallStackSerialiser manager) + act + +withRootStackProfiler :: Bool -> (StackProfilerManager -> IO a) -> IO a +withRootStackProfiler shouldRun act = + bracket + (runNewStackProfilerManager shouldRun) + shutdownStackProfilerManager + act + +-- ---------------------------------------------------------------------------- +-- Low-level user API +-- ---------------------------------------------------------------------------- + +runNewStackProfilerManager :: Bool -> IO StackProfilerManager +runNewStackProfilerManager shouldRun = do + manager <- newStackProfilerManager shouldRun + startEventLoopThread manager + FFI.installEventlogSocketHandlers manager `catches` FFI.defaultErrorHandlers + pure manager + +shutdownStackProfilerManager :: StackProfilerManager -> IO () +shutdownStackProfilerManager manager = do + shutdownAllSamplerThreads manager + -- TODO: we could also send a stop command instead + shutdownEventLoop manager + +runWithStackProfiler :: StackProfilerManager -> ThreadSampler -> CallStackSerialiser -> IO a -> IO a +runWithStackProfiler manager sampler serializer act = do + bracket + (setupStackProfilerThread manager sampler serializer) + (stopStackProfilerThread manager) + (const act) + +stopStackProfilerThread :: StackProfilerManager -> Async () -> IO () +stopStackProfilerThread MkStackProfilerManager{profilerThreads} profilerThread = do + cancel profilerThread + `finally` atomically + ( do + STM.modifyTVar' + profilerThreads + ( \threadMap -> + (Map.delete (asyncThreadId profilerThread) threadMap) + ) + ) + +setupStackProfilerThread :: + StackProfilerManager -> + ThreadSampler -> + CallStackSerialiser -> + IO (Async ()) +setupStackProfilerThread manager sampler serialiser = do + barrier <- newEmptyMVar + workerThread <- async $ do + () <- takeMVar barrier + sampleThreadId <- myThreadId + labelThread sampleThreadId ("Sample Profiler Thread " <> show (fromThreadId sampleThreadId)) + forever $ do + runStackProfilerSample sampler serialiser + + -- Add this thread to the list of known worker threads to make sure it isn't accidentally sampled + addSamplerThread manager workerThread + putMVar barrier () + pure workerThread + +-- ---------------------------------------------------------------------------- +-- Sample the RTS CallStack of one or more threads +-- ---------------------------------------------------------------------------- + +data ThreadSampler = MkThreadSampler + { listThreadsToSample :: IO [ThreadId] + , delaySamplerThread :: IO () + , waitForProfilingStart :: IO () + } + +defaultThreadSampler :: StackProfilerManager -> ProfilerSamplingInterval -> ThreadSampler +defaultThreadSampler manager delay = + MkThreadSampler + { listThreadsToSample = do + pure [] + , delaySamplerThread = + threadDelay (profilerSamplingIntervalToThreadDelayTime delay) + , waitForProfilingStart = + atomically $ do + STM.check =<< shouldProfile manager + } + +singleThreadSampler :: StackProfilerManager -> ProfilerSamplingInterval -> ThreadId -> ThreadSampler +singleThreadSampler manager delay tid = + (defaultThreadSampler manager delay) + { listThreadsToSample = do + pure [tid] + } + +allThreadSampler :: StackProfilerManager -> ProfilerSamplingInterval -> ThreadSampler +allThreadSampler manager delay = + (defaultThreadSampler manager delay) + { listThreadsToSample = do + tids <- listThreads + userThreads <- filterM (isThreadOfInterest manager) tids + pure userThreads + } + +runStackProfilerSample :: ThreadSampler -> CallStackSerialiser -> IO () +runStackProfilerSample sampler serialiser = do + waitForProfilingStart sampler + tids <- listThreadsToSample sampler + mapM_ (runCallStackSerialiser serialiser) tids + -- TODO: this is wrong, we don't sample every delay time as sampling takes time as well + delaySamplerThread sampler + +-- ---------------------------------------------------------------------------- +-- Serialise the RTS CallStack for the eventlog +-- ---------------------------------------------------------------------------- + +data CallStackSerialiser = MkCallStackSerialiser + { sampleCallStack :: ThreadId -> IO (Maybe ThreadSample) + , decodeThreadSample :: ThreadSample -> IO CallStackMessage + , serialiseCallStackMessage :: CallStackMessage -> IO () + } + +-- | If the thread's callstack can be sampled, we serialise the sample +-- and write into the eventlog for later processing. +runCallStackSerialiser :: CallStackSerialiser -> ThreadId -> IO () +runCallStackSerialiser serialiser tid = do + sampleCallStack serialiser tid >>= \case + Nothing -> pure () + Just threadSample -> do + callStackSample <- decodeThreadSample serialiser threadSample + serialiseCallStackMessage serialiser callStackSample + +defaultCallStackSerialiser :: StackProfilerManager -> CallStackSerialiser +defaultCallStackSerialiser manager = + MkCallStackSerialiser + { sampleCallStack = sampleThread + , decodeThreadSample = threadSampleToCallStackMessage + , serialiseCallStackMessage = \callStackSample -> do + lbss <- atomically $ do + eventlogMessages <- serializeCallStackMessage (symbolTableRef manager) callStackSample + let + lbss = serializeBinaryEventlogMessages eventlogMessages + -- Only write this message if we are still profiling + STM.check =<< shouldProfile manager + pure lbss + + writeChan (messageChan manager) (WriteProfileSample $ fmap LBS.toStrict lbss) + } + +-- | Sample the stack of the 'ThreadId' if the thread is currently running. +-- If the thread is not running (e.g., because it is dead), then we return 'Nothing'. +sampleThread :: ThreadId -> IO (Maybe ThreadSample) +sampleThread tid = do + tidStatus <- threadStatus tid + (cap, _lockedToCap) <- threadCapability tid + case canCloneStack tidStatus of + True -> do + stack <- cloneThreadStack tid + pure $ + Just $ + ThreadSample + { threadSampleId = tid + , threadSampleCapability = MkCapabilityId $ intToWord64 cap + , threadSampleStackSnapshot = stack + } + False -> do + -- Only running threads need to be sampled + pure Nothing + where + canCloneStack :: ThreadStatus -> Bool + canCloneStack = \case + ThreadRunning -> True + ThreadBlocked BlockedOnMVar -> True + _ -> False + +-- ---------------------------------------------------------------------------- +-- Main Event Loop handler +-- ---------------------------------------------------------------------------- + +startEventLoopThread :: StackProfilerManager -> IO () +startEventLoopThread manager = do + !sinkAsync <- do + sinkAsync <- async (forever mainEventHandler) + + -- if the main eventloop crashes for any reason, we want to know + link sinkAsync + + pure + MkEventThread + { eventThread = sinkAsync + } + + atomically $ do + writeTVar (mainEventLoopThread manager) (Just sinkAsync) + where + mainEventHandler = do + msg <- Chan.readChan (messageChan manager) + run <- STM.atomically $ shouldProfile manager + case msg of + WriteProfileSample msgs -> + case run of + True -> + mapM_ Compat.traceBinaryEventIO msgs + False -> + -- If we received a sample but the eventlog is currently locked + -- discard the message. + pure () + StartProfiling barrier -> do + STM.atomically $ enableSampling manager + putMVar barrier () + StopProfiling barrier -> do + STM.atomically $ disableSampling manager + putMVar barrier () + StartEventlog barrier -> do + STM.atomically $ enableEventLogging manager + putMVar barrier () + StopEventlog barrier -> do + STM.atomically $ disableEventLogging manager + putMVar barrier () + PublishInitEvents barrier -> do + symbolTable <- STM.atomically $ readSymbolTable (symbolTableRef manager) + let + msgs = Decode.initMessages symbolTable + + mapM_ + Compat.traceBinaryEventIO + (fmap LBS.toStrict msgs) + + Debug.Trace.flushEventLog + putMVar barrier () + +--------------------------------------------------------------------- +-- Coordination utils +-- ---------------------------------------------------------------------------- + +shutdownEventLoop :: StackProfilerManager -> IO () +shutdownEventLoop manager = do + sinkAsync <- atomically $ do + thread <- readTVar (mainEventLoopThread manager) + writeTVar (mainEventLoopThread manager) Nothing + pure thread + + sendStopProfilingMessage manager + traverse_ (cancel . eventThread) sinkAsync + +addSamplerThread :: StackProfilerManager -> Async () -> IO () +addSamplerThread manager worker = do + -- if the worker crashes for any reason, we want to know + link worker + + atomically $ do + STM.modifyTVar' (profilerThreads manager) $ \threadMap -> + (Map.insert (asyncThreadId worker) worker threadMap) + +shutdownAllSamplerThreads :: StackProfilerManager -> IO () +shutdownAllSamplerThreads MkStackProfilerManager{profilerThreads} = do + threads <- atomically $ do + threadsMap <- readTVar profilerThreads + writeTVar profilerThreads Map.empty + pure $ Map.elems threadsMap + + traverse_ cancel threads + +-- ---------------------------------------------------------------------------- +-- Utils +-- ---------------------------------------------------------------------------- + +-- | We don't want to sample the stack profiler threads themselves. +isProfilerThread :: Maybe EventThread -> Set ThreadId -> ThreadId -> Bool +isProfilerThread writerThread profilerThreadIds tid = + Set.member tid profilerThreadIds + || maybe False (== tid) (asyncThreadId . eventThread <$> writerThread) + +-- | RTS threads are often not that interesting, we much rather want to focus on +-- the user code. +isRtsThread :: ThreadId -> Maybe String -> Bool +isRtsThread _ Nothing = False +isRtsThread _tid (Just lbl) = + lbl == "TimerManager" || "IOManager on cap" `List.isPrefixOf` lbl + +isThreadOfInterest :: StackProfilerManager -> ThreadId -> IO Bool +isThreadOfInterest manager tid = do + lbl <- threadLabel tid + (profilerThreadIds, eventlogWriter) <- STM.atomically $ do + threadMap <- readTVar (profilerThreads manager) + sink <- readTVar (mainEventLoopThread manager) + pure (Map.keysSet threadMap, sink) + pure $ + not $ + or + [ isProfilerThread eventlogWriter profilerThreadIds tid + , isRtsThread tid lbl + ] diff --git a/src/GHC/Stack/Profiler/Commands.hs b/src/GHC/Stack/Profiler/Commands.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Commands.hs @@ -0,0 +1,96 @@ +module GHC.Stack.Profiler.Commands ( + startProfiling, + stopProfiling, + sendPublishInitEventMessages, + sendStartProfilingMessage, + sendStopProfilingMessage, + sendEnableEventlogMessage, + sendDisableEventlogMessage, +) where + +import Control.Concurrent.Chan +import qualified Control.Concurrent.MVar as MVar +import qualified Control.Concurrent.STM as STM +import GHC.Stack.Profiler.Manager + +-- | Start the profiler threads. +-- +-- Blocks until all threads started running. +startProfiling :: StackProfilerManager -> IO () +startProfiling manager = do + -- TODO: this atomically is redundant, the main loop thread + -- sets it anyway + STM.atomically $ + STM.writeTVar (isThreadSamplerRunning manager) True + sendStartProfilingMessage manager + +-- | Stop the running profiler threads. +-- +-- Blocks until all threads stopped running. +stopProfiling :: StackProfilerManager -> IO () +stopProfiling manager = do + -- TODO: this atomically is *not* redundant, it makes sure no new + -- samples can be created. + -- Otherwise, new samples could be created and queued while we are waiting + -- for the event loop to process this message. + -- It is important, that once this message is processed, that no sampler thread is sampling + -- at all. Otherwise, there will be new init events that are not published. + STM.atomically $ + STM.writeTVar (isThreadSamplerRunning manager) False + sendStopProfilingMessage manager + +-- | Start profiling. +-- +-- Blocks until the message has been processed by the main event loop. +sendStartProfilingMessage :: StackProfilerManager -> IO () +sendStartProfilingMessage manager = do + barrier <- MVar.newEmptyMVar + writeChan + (messageChan manager) + (StartProfiling barrier) + MVar.takeMVar barrier + +-- | Stop profiling. +-- +-- Blocks until the message has been processed by the main event loop. +sendStopProfilingMessage :: StackProfilerManager -> IO () +sendStopProfilingMessage manager = do + barrier <- MVar.newEmptyMVar + writeChan + (messageChan manager) + (StopProfiling barrier) + MVar.takeMVar barrier + +-- | Start EventLogging now. +-- +-- Blocks until the message has been processed by the main event loop. +sendEnableEventlogMessage :: StackProfilerManager -> IO () +sendEnableEventlogMessage manager = do + barrier <- MVar.newEmptyMVar + writeChan + (messageChan manager) + (StartEventlog barrier) + MVar.takeMVar barrier + +-- | Stop EventLogging now. +-- +-- Blocks until the message has been processed by the main event loop. +sendDisableEventlogMessage :: StackProfilerManager -> IO () +sendDisableEventlogMessage manager = do + barrier <- MVar.newEmptyMVar + writeChan + (messageChan manager) + (StopEventlog barrier) + MVar.takeMVar barrier + +-- | Publish all init messages so far. +-- +-- Blocks until the init events have been written to the eventlog and +-- eventlog was flushed. +sendPublishInitEventMessages :: StackProfilerManager -> IO () +sendPublishInitEventMessages manager = do + barrier <- MVar.newEmptyMVar + writeChan + (messageChan manager) + (PublishInitEvents barrier) + MVar.takeMVar barrier diff --git a/src/GHC/Stack/Profiler/Decode.hs b/src/GHC/Stack/Profiler/Decode.hs --- a/src/GHC/Stack/Profiler/Decode.hs +++ b/src/GHC/Stack/Profiler/Decode.hs @@ -1,40 +1,97 @@ module GHC.Stack.Profiler.Decode ( - SymbolTable, - serializeThreadSample, + StackSymbolTable, + SymbolTableWriter, + initMessages, + serializeCallStackMessage, + serializeBinaryEventlogMessage, + serializeBinaryEventlogMessages, threadSampleToCallStackMessage, + binaryEventlogDefinitions, ) where +import Control.Concurrent.STM import Data.Binary import Data.Binary.Put import qualified Data.ByteString.Lazy as LBS -import Data.IORef import qualified Data.List.NonEmpty as NonEmpty -import Data.Tuple -import GHC.Internal.Conc.Sync +import GHC.Conc.Sync (fromThreadId) +import Control.Exception (assert) +import GHC.Stack.Profiler.Core.Eventlog import GHC.Stack.Profiler.Core.SymbolTable import GHC.Stack.Profiler.Core.ThreadSample -import GHC.Stack.Profiler.Core.Eventlog import GHC.Stack.Profiler.Stack.Decode (decodeStackWithIpProvId) +import GHC.Stack.Profiler.SymbolTable -type SymbolTable = SymbolTableWriter MapTable +threadSampleToCallStackMessage :: ThreadSample -> IO CallStackMessage +threadSampleToCallStackMessage sample = do + frames <- decodeStackWithIpProvId $ threadSampleStackSnapshot sample + let + -- removes immediate duplicates + callStackItems = fmap NonEmpty.head $ NonEmpty.group frames -serializeThreadSample :: IORef SymbolTable -> ThreadSample -> IO [LBS.ByteString] -serializeThreadSample tableRef sample = do - eventlogMessages <- threadSampleToCallStackMessage tableRef sample - pure $ map (runPut . put) eventlogMessages + pure + MkCallStackMessage + { callThreadId = fromThreadId $ threadSampleId sample + , callCapabilityId = threadSampleCapability sample + , callStack = callStackItems + } -threadSampleToCallStackMessage :: IORef SymbolTable -> ThreadSample -> IO [BinaryEventlogMessage] -threadSampleToCallStackMessage tableRef sample = do - frames <- decodeStackWithIpProvId $ threadSampleStackSnapshot sample - -- removes immediate duplicates - let callStackItems = fmap NonEmpty.head $ NonEmpty.group frames - let callStackMessage = MkCallStackMessage - { callThreadId = fromThreadId $ threadSampleId sample - , callCapabilityId = threadSampleCapability sample - , callStack = callStackItems - } - -- TODO: Abstract IORef SymbolTable somehow - atomicModifyIORef' tableRef $ \ table -> - swap $ dehydrateCallStackMessage table callStackMessage +serializeCallStackMessage :: StackSymbolTable -> CallStackMessage -> STM [BinaryEventlogMessage] +serializeCallStackMessage tableRef callStackMessage = do + table <- readSymbolTable tableRef + let + (eventlogMessages, newTable) = dehydrateCallStackMessage table callStackMessage + writeSymbolTable newTable tableRef + pure eventlogMessages + +serializeBinaryEventlogMessage :: BinaryEventlogMessage -> LBS.ByteString +serializeBinaryEventlogMessage = runPut . put + +serializeBinaryEventlogMessages :: [BinaryEventlogMessage] -> [LBS.ByteString] +serializeBinaryEventlogMessages = map serializeBinaryEventlogMessage + +initMessages :: SymbolTableWriter MapTable -> [LBS.ByteString] +initMessages symbolTable = + let + (stringDefs, srcLocDefs) = binaryEventlogDefinitions symbolTable + binaryEventlogMessages = + ( map StringDef stringDefs + ++ map SourceLocationDef srcLocDefs + ) + in + serializeBinaryEventlogMessages binaryEventlogMessages + +binaryEventlogDefinitions :: SymbolTableWriter MapTable -> ([BinaryStringMessage], [BinarySourceLocationMessage]) +binaryEventlogDefinitions table = + let + knownStrings = getKnownStrings $ writerTable table + knownSrcLocs = getKnownSourceLocations $ writerTable table + + stringDefs = + fmap (uncurry MkBinaryStringMessage) knownStrings + + srcLocDefs = + map (uncurry go) knownSrcLocs + in + ( stringDefs + , srcLocDefs + ) + where + go :: SourceLocationId -> SourceLocation -> BinarySourceLocationMessage + go sid s = + let + (funcId, newFuncName, _) = lookupOrInsertText table (writerTable table) (functionName s) + (fileId, newFileName, _) = lookupOrInsertText table (writerTable table) (fileName s) + in + -- These should always be found + assert (not newFuncName) $ + assert (not newFileName) $ + MkBinarySourceLocationMessage + { binarySourceLocationMessageId = sid + , binarySourceLocationRow = line s + , binarySourceLocationColumn = column s + , binarySourceLocationFunctionId = funcId + , binarySourceLocationFilename = fileId + } diff --git a/src/GHC/Stack/Profiler/FFI.hs b/src/GHC/Stack/Profiler/FFI.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/FFI.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module GHC.Stack.Profiler.FFI ( + installEventlogSocketHandlers, + defaultErrorHandlers, +) where + +#if defined(EVENTLOG_SOCKET_SUPPORT) +import GHC.Eventlog.Socket +import System.IO (hPutStrLn, stderr) +#endif + +import Control.Exception +import qualified Control.Monad.STM as STM +import GHC.Stack.Profiler.Manager +import GHC.Stack.Profiler.Commands + +#if defined(EVENTLOG_SOCKET_SUPPORT) +startProfilerCommandId :: CommandId +startProfilerCommandId = CommandId 0x1 + +stopProfilerCommandId :: CommandId +stopProfilerCommandId = CommandId 0x2 +#endif + +-- | Install the @eventlog-socket@ custom command handlers and lifecycle hooks. +-- +-- The supported custom commands are: +-- * Start the profiler +-- * Stop the profiler +-- +-- We implement the lifecycle hooks for stopping the eventlog and starting +-- writing to the eventlog. +-- When we start eventlogging, we post the definitions of the existing callstack +-- definitions, e.g., string and source locations. +-- +-- May throw 'EventlogSocketControlError' when registering @eventlog-socket@ +-- hooks fails. +installEventlogSocketHandlers :: StackProfilerManager -> IO () +installEventlogSocketHandlers = +#if defined(EVENTLOG_SOCKET_SUPPORT) + \ manager -> do + registerEventlogSocketHooks manager + where + registerEventlogSocketHooks manager = do + registerHook HookPostStartEventLogging $ + startEventLoggingHook manager + registerHook HookPreEndEventLogging $ + endEventLoggingHook manager + ns <- registerNamespace "ghc-stack-profiler" + registerCommand ns startProfilerCommandId (startProfilerCommand manager) + registerCommand ns stopProfilerCommandId (stopProfilerCommand manager) +#else + \ _manager -> + pure () +#endif + +defaultErrorHandlers :: [Handler ()] +defaultErrorHandlers = + [ +#if defined(EVENTLOG_SOCKET_SUPPORT) + Handler $ \ (e :: EventlogSocketControlError) -> do + hPutStrLn stderr "Failed to register eventlog-socket commands" + hPutStrLn stderr (displayException e) +#endif + ] + +-- | Post-start EventLogging hook. +-- +-- 1. Publish init events and flush the eventlog. +-- 2. Inform the main loop that the eventlog is ready for messages now. +startEventLoggingHook :: StackProfilerManager -> IO () +startEventLoggingHook manager = do + sendPublishInitEventMessages manager + -- Block until start message has been processed + sendEnableEventlogMessage manager + +-- | Pre-end EventLogging hook. +endEventLoggingHook :: StackProfilerManager -> IO () +endEventLoggingHook manager = do + -- Disallow logging any more messages to the eventlog. + -- Stops the profiler sampling threads. + STM.atomically $ disableEventLogging manager + + -- Block until all messages have been processed + sendDisableEventlogMessage manager + +startProfilerCommand :: StackProfilerManager -> IO () +startProfilerCommand manager = do + startProfiling manager + +stopProfilerCommand :: StackProfilerManager -> IO () +stopProfilerCommand manager = do + stopProfiling manager diff --git a/src/GHC/Stack/Profiler/Manager.hs b/src/GHC/Stack/Profiler/Manager.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/Manager.hs @@ -0,0 +1,100 @@ +module GHC.Stack.Profiler.Manager ( + StackProfilerManager (..), + newStackProfilerManager, + shouldProfile, + EventThread (..), + ProfilerMessage (..), + enableEventLogging, + disableEventLogging, + enableSampling, + disableSampling, +) where + +import Control.Concurrent (ThreadId) +import Control.Concurrent.Async (Async) +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent.STM (STM) +import Control.Concurrent.STM.TVar +import qualified Control.Concurrent.STM.TVar as TVar +import Data.ByteString (ByteString) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Debug.Trace.Binary.Compat as Compat +import GHC.Generics (Generic) +import GHC.Stack.Profiler.SymbolTable + +-- | A 'StackProfilerManager' records all the relevant information +-- to manage the ghc stack profiler run-time. +data StackProfilerManager = MkStackProfilerManager + { profilerThreads :: !(TVar (Map ThreadId (Async ()))) + -- ^ 'Async' of the stack sampling thread. + , mainEventLoopThread :: !(TVar (Maybe EventThread)) + -- ^ Main event loop thread responsible for processing profiler messages, etc... + , symbolTableRef :: !StackSymbolTable + -- ^ Global table for common symbols. + , isThreadSamplerRunning :: !(TVar Bool) + -- ^ Is the profiler currently running? + -- + -- Can be controlled via 'startProfiler' and 'stopProfiler'. + -- This variable describes whether the user wants to profile, regardless + -- of the eventlog state. + , isEventlogStarted :: !(TVar Bool) + -- ^ Is there an eventlog? + -- + -- It is fully possible that we start profiling but no eventlog-writer + -- being connected/configured. The eventlog can be enabled at a later point, + -- or stopped/started via @eventlog-socket@. + -- This variable tracks the state of the eventlog-writer. + , messageChan :: Chan ProfilerMessage + } + deriving (Generic, Eq) + +data ProfilerMessage + = WriteProfileSample [ByteString] + | PublishInitEvents (MVar ()) + | StartProfiling (MVar ()) + | StopProfiling (MVar ()) + | StartEventlog (MVar ()) + | StopEventlog (MVar ()) + +newStackProfilerManager :: Bool -> IO StackProfilerManager +newStackProfilerManager running = do + tracingEnabled <- Compat.userTracingEnabledIO + MkStackProfilerManager + <$> newTVarIO Map.empty + <*> newTVarIO Nothing + <*> emptySymbolTableIO + <*> newTVarIO running + <*> newTVarIO tracingEnabled + <*> newChan + +data EventThread = MkEventThread + { eventThread :: !(Async ()) + } + +-- | Can we profile right now? +-- +-- We only sample a stack if the profiler is instructed to run and the eventlog is enabled. +shouldProfile :: StackProfilerManager -> STM Bool +shouldProfile manager = + liftA2 + (&&) + (readTVar $ isThreadSamplerRunning manager) + (readTVar $ isEventlogStarted manager) + +enableEventLogging :: StackProfilerManager -> STM () +enableEventLogging manager = do + TVar.writeTVar (isEventlogStarted manager) True + +disableEventLogging :: StackProfilerManager -> STM () +disableEventLogging manager = do + TVar.writeTVar (isEventlogStarted manager) False + +enableSampling :: StackProfilerManager -> STM () +enableSampling manager = do + TVar.writeTVar (isThreadSamplerRunning manager) True + +disableSampling :: StackProfilerManager -> STM () +disableSampling manager = do + TVar.writeTVar (isThreadSamplerRunning manager) False diff --git a/src/GHC/Stack/Profiler/Sampler.hs b/src/GHC/Stack/Profiler/Sampler.hs deleted file mode 100644 --- a/src/GHC/Stack/Profiler/Sampler.hs +++ /dev/null @@ -1,180 +0,0 @@ -module GHC.Stack.Profiler.Sampler ( - -- * Run sample profiler - withStackProfiler, - withStackProfilerForMyThread, - withStackProfilerForThread, - -- * Configuration of sample profiler - StackProfilerManager(..), - ProfilerSamplingInterval(..), - -- * Basic thread sampler - sampleThread, - -- * Low level helpers for setting up custom - -- sample profilers threads - runWithStackProfiler, - setupStackProfilerManager, - stopStackProfilerManager, - sampleToEventlog, - -- * Thread filtering - isProfilerThread, - isRtsThread, - ) where - -import Control.Concurrent -import Control.Exception -import Control.Monad -import qualified Data.ByteString.Lazy as LBS -import qualified Data.List as List -import Data.IORef -import GHC.Conc -import GHC.Conc.Sync - -import GHC.Stack.CloneStack (cloneThreadStack) - -import qualified Debug.Trace.Binary.Compat as Compat -import GHC.Stack.Profiler.Decode -import GHC.Stack.Profiler.Core.Eventlog -import GHC.Stack.Profiler.Core.ThreadSample -import GHC.Stack.Profiler.Core.SymbolTable -import GHC.Stack.Profiler.Core.Util - --- | A 'StackProfilerManager' records all the relevant information --- to manage the ghc stack profiler run-time. -data StackProfilerManager = MkStackProfilerManager - { profilerThreadId :: ThreadId - -- ^ 'ThreadId' of the stack sampling thread. - , symbolTableRef :: IORef SymbolTable - } deriving (Eq) - --- | Sampling intervals for the stack profiler. -data ProfilerSamplingInterval - = SampleIntervalMs Int - -- ^ Sample every @n@ milliseconds. - -- - -- Recommended value: @'SampleIntervalMs' 10@ or @'SampleIntervalMs' 20@. - deriving (Show, Eq, Ord) - -profilerSamplingIntervalToThreadDelayTime :: ProfilerSamplingInterval -> Int -profilerSamplingIntervalToThreadDelayTime = \ case - SampleIntervalMs n -> n * 1000 - --- ---------------------------------------------------------------------------- --- High-Level user API --- ---------------------------------------------------------------------------- - --- | Sample the all non-rts threads every 'ProfilerSamplingInterval' for the duration of --- the wrapped action. --- Once the wrapped action terminates, the stack profiling stops. --- --- RTS threads such as the 'TimerManager' and 'IOManager' are not sampled as these --- are usually not interesting for user code. -withStackProfiler :: ProfilerSamplingInterval -> IO a -> IO a -withStackProfiler delay act = do - runWithStackProfiler sampleAction delay act - where - sampleAction config = do - tids <- listThreads - userThreads <- filterM (isThreadOfInterest config) tids - forM_ userThreads $ \tid -> - sampleToEventlog (symbolTableRef config) tid - - isThreadOfInterest :: StackProfilerManager -> ThreadId -> IO Bool - isThreadOfInterest config tid = do - lbl <- threadLabel tid - pure $ not $ or - [ isProfilerThread config tid lbl - , isRtsThread tid lbl - ] - --- | Sample the current thread every 'ProfilerSamplingInterval' for the duration of --- the wrapped action. --- Once the wrapped action terminates, the stack profiling stops. -withStackProfilerForMyThread :: ProfilerSamplingInterval -> IO a -> IO a -withStackProfilerForMyThread delay act = do - tid <- myThreadId - withStackProfilerForThread tid delay act - --- | Sample a specific 'ThreadId' every 'ProfilerSamplingInterval' for the duration of --- the wrapped action. --- Once the wrapped action terminates, the stack profiling stops. -withStackProfilerForThread :: ThreadId -> ProfilerSamplingInterval -> IO a -> IO a -withStackProfilerForThread tid delay act = - runWithStackProfiler (\ config -> sampleToEventlog (symbolTableRef config) tid) delay act - --- ---------------------------------------------------------------------------- --- Low-level user API --- ---------------------------------------------------------------------------- - -runWithStackProfiler :: (StackProfilerManager -> IO ()) -> ProfilerSamplingInterval -> IO a -> IO a -runWithStackProfiler sampleAction delay act = do - if Compat.userTracingEnabled - then bracket (setupStackProfilerManager sampleAction delay) stopStackProfilerManager (const act) - else act - -stopStackProfilerManager :: StackProfilerManager -> IO () -stopStackProfilerManager MkStackProfilerManager{profilerThreadId} = - killThread profilerThreadId - -setupStackProfilerManager :: (StackProfilerManager -> IO ()) -> ProfilerSamplingInterval -> IO StackProfilerManager -setupStackProfilerManager sampleAction delay = do - samplerThreadConfigMVar <- newEmptyMVar - sid <- forkIO $ do - config <- takeMVar samplerThreadConfigMVar - sampleThreadId <- myThreadId - labelThread sampleThreadId "Sample Profiler Thread" - forever $ do - sampleAction config - -- TODO: this is wrong, we don't sample every delay time as sampling takes time as well - threadDelay (profilerSamplingIntervalToThreadDelayTime delay) - - tableRef <- newIORef emptyMapSymbolTableWriter - let sampleThreadConf = MkStackProfilerManager - { profilerThreadId = sid - , symbolTableRef = tableRef - } - putMVar samplerThreadConfigMVar sampleThreadConf - pure sampleThreadConf - --- | We don't want to sample the stack profiler itself. -isProfilerThread :: StackProfilerManager -> ThreadId -> Maybe String -> Bool -isProfilerThread MkStackProfilerManager {profilerThreadId} tid _lbl = tid == profilerThreadId - --- | RTS threads are often not that interesting, we much rather want to focus on --- the user code. -isRtsThread :: ThreadId -> Maybe String -> Bool -isRtsThread _ Nothing = False -isRtsThread _tid (Just lbl) = - lbl `elem` ["TimerManager"] || "IOManager on cap" `List.isPrefixOf` lbl - --- | Sample the stack of the 'ThreadId' if the thread is currently running. --- If the thread is not running (e.g., because it is dead), then we return 'Nothing'. -sampleThread :: ThreadId -> IO (Maybe ThreadSample) -sampleThread tid = do - tidStatus <- threadStatus tid - (cap, _lockedToCap) <- threadCapability tid - case canCloneStack tidStatus of - True -> do - stack <- cloneThreadStack tid - pure $ Just $ ThreadSample - { threadSampleId = tid - , threadSampleCapability = MkCapabilityId $ intToWord64 cap - , threadSampleStackSnapshot = stack - } - False -> do - -- Only running threads need to be sampled - pure Nothing - where - canCloneStack :: ThreadStatus -> Bool - canCloneStack = \ case - ThreadRunning -> True - ThreadBlocked BlockedOnMVar -> True - _ -> False - --- | If the thread's callstack can be sampled, we serialise the sample --- and write into the eventlog for later processing. -sampleToEventlog :: IORef SymbolTable -> ThreadId -> IO () -sampleToEventlog tableRef tid = do - sampleThread tid >>= \ case - Nothing -> pure () - Just threadSample -> do - msgs <- serializeThreadSample tableRef threadSample - mapM_ (Compat.traceBinaryEventIO . LBS.toStrict) msgs diff --git a/src/GHC/Stack/Profiler/Stack/Compat.hs b/src/GHC/Stack/Profiler/Stack/Compat.hs --- a/src/GHC/Stack/Profiler/Stack/Compat.hs +++ b/src/GHC/Stack/Profiler/Stack/Compat.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + module GHC.Stack.Profiler.Stack.Compat ( lookupIpeIdForStackFrame, ) where @@ -22,7 +23,5 @@ -- So, to check whether there is an InfoProv, we first lookup by the 'StgInfoTable' ptr, -- i.e. not adjusting for 'TABLES_NEXT_TO_CODE', but if there is an entry, we use the -- the struct address, otherwise the decoder will not be able to find the 'InfoProv'. - pure $ castPtrToWord64 (infoTableStructPtr itbl) <$ mId + pure $! castPtrToWord64 (infoTableStructPtr itbl) <$ mId #endif - - diff --git a/src/GHC/Stack/Profiler/Stack/Decode.hs b/src/GHC/Stack/Profiler/Stack/Decode.hs --- a/src/GHC/Stack/Profiler/Stack/Decode.hs +++ b/src/GHC/Stack/Profiler/Stack/Decode.hs @@ -1,24 +1,25 @@ {-# LANGUAGE MagicHash #-} + module GHC.Stack.Profiler.Stack.Decode ( decodeStackWithIpProvId, ) where -import Unsafe.Coerce (unsafeCoerce) import Data.Maybe (catMaybes) import qualified Data.Text as Text import Data.Typeable (cast) +import Unsafe.Coerce (unsafeCoerce) -import GHC.Stack.Annotation.Experimental.Compat -import GHC.Stack.CloneStack (StackSnapshot(..)) import GHC.Internal.ClosureTypes.Compat import GHC.Internal.Stack.Constants.Compat import GHC.Internal.Stack.Decode.Compat as Decode import GHC.Internal.Stack.Types +import GHC.Stack.Annotation.Experimental.Compat +import GHC.Stack.CloneStack (StackSnapshot (..)) import GHC.Exts.Heap.InfoTable.Types -import GHC.Stack.Profiler.Core.ThreadSample import GHC.Stack.Profiler.Core.Eventlog +import GHC.Stack.Profiler.Core.ThreadSample import GHC.Stack.Profiler.Core.Util import GHC.Stack.Profiler.Stack.Compat (lookupIpeIdForStackFrame) @@ -27,19 +28,20 @@ info <- getInfoTableForStack stack# case tipe info of STACK -> do - let sfls = stackFrameLocations stack# + let + sfls = stackFrameLocations stack# stack' <- stackFrameLocationItems sfls pure stack' _ -> error $ "Expected STACK closure, got " ++ show info - where - stackFrameLocations :: StackSnapshot# -> [StackFrameLocation] - stackFrameLocations s# = - stackHead s# - : go (advanceStackFrameLocation (stackHead s#)) - where - go :: Maybe StackFrameLocation -> [StackFrameLocation] - go Nothing = [] - go (Just r) = r : go (advanceStackFrameLocation r) + where + stackFrameLocations :: StackSnapshot# -> [StackFrameLocation] + stackFrameLocations s# = + stackHead s# + : go (advanceStackFrameLocation (stackHead s#)) + where + go :: Maybe StackFrameLocation -> [StackFrameLocation] + go Nothing = [] + go (Just r) = r : go (advanceStackFrameLocation r) stackFrameLocationItems :: [StackFrameLocation] -> IO [StackItem] stackFrameLocationItems frames = @@ -50,26 +52,29 @@ stackItbl <- getInfoTableOnStack stack# index case tipe (infoTable stackItbl) of ANN_FRAME -> - let Box annotation = getClosureBox stack# (index + offsetStgAnnFrameAnn) - in pure $ stackAnnotationToStackItem (unsafeCoerce annotation) + let + Box annotation = getClosureBox stack# (index + offsetStgAnnFrameAnn) + in + pure $ stackAnnotationToStackItem (unsafeCoerce annotation) _ -> fmap (IpeId . MkIpeId) <$> lookupIpeIdForStackFrame stackItbl stackAnnotationToStackItem :: SomeStackAnnotation -> Maybe StackItem -stackAnnotationToStackItem = \ case +stackAnnotationToStackItem = \case 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 - } - + ((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 diff --git a/src/GHC/Stack/Profiler/SymbolTable.hs b/src/GHC/Stack/Profiler/SymbolTable.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Profiler/SymbolTable.hs @@ -0,0 +1,37 @@ +module GHC.Stack.Profiler.SymbolTable ( + -- * 'StackSymbolTable' type + StackSymbolTable, + emptySymbolTable, + emptySymbolTableIO, + readSymbolTable, + writeSymbolTable, +) where + +import Control.Concurrent.STM +import GHC.Generics (Generic) +import GHC.Stack.Profiler.Core.SymbolTable + +-- | A @'SymbolTableWriter' 'MapTable'@ guarded by a lock for mutable, concurrent access. +-- +-- The lock is an 'MVar', but this is considered an implementation detail that may change without warning. +newtype StackSymbolTable = MkStackSymbolTable + { writerSymbolTable :: TVar (SymbolTableWriter MapTable) + } + deriving (Generic, Eq) + +-- | Create an empty 'StackSymbolTable' +emptySymbolTableIO :: IO StackSymbolTable +emptySymbolTableIO = atomically emptySymbolTable + +emptySymbolTable :: STM StackSymbolTable +emptySymbolTable = + MkStackSymbolTable + <$> newTVar emptyMapSymbolTableWriter + +readSymbolTable :: StackSymbolTable -> STM (SymbolTableWriter MapTable) +readSymbolTable = + readTVar . writerSymbolTable + +writeSymbolTable :: SymbolTableWriter MapTable -> StackSymbolTable -> STM () +writeSymbolTable newWriterTbl symTbl = + writeTVar (writerSymbolTable symTbl) newWriterTbl diff --git a/src/GHC/Stack/Profiler/Util.hs b/src/GHC/Stack/Profiler/Util.hs --- a/src/GHC/Stack/Profiler/Util.hs +++ b/src/GHC/Stack/Profiler/Util.hs @@ -2,8 +2,8 @@ castPtrToWord64, ) where -import Foreign.Ptr import Data.Word +import Foreign.Ptr castPtrToWord64 :: Ptr a -> Word64 castPtrToWord64 ptr = case ptrToWordPtr ptr of