ghc-stack-profiler 0.1.0.0 → 0.2.0.0
raw patch · 18 files changed
+954/−288 lines, 18 filesdep +asyncdep +containersdep +eventlog-socketdep ~binarydep ~ghc-primdep ~ghc-stack-profiler-core
Dependencies added: async, containers, eventlog-socket, stm
Dependency ranges changed: binary, ghc-prim, ghc-stack-profiler-core
Files
- CHANGELOG.md +8/−0
- cbits/Stack.cmm +16/−11
- ghc-stack-profiler.cabal +44/−9
- src/Debug/Trace/Binary/Compat.hs +13/−6
- src/GHC/Internal/Heap/Closures/Compat.hs +2/−1
- src/GHC/Internal/Stack/Constants/Compat.hs +2/−2
- src/GHC/Internal/Stack/Decode/Compat.hs +29/−23
- src/GHC/Stack/Annotation/Experimental/Compat.hs +4/−3
- src/GHC/Stack/Profiler.hs +393/−0
- src/GHC/Stack/Profiler/Commands.hs +96/−0
- src/GHC/Stack/Profiler/Decode.hs +81/−24
- src/GHC/Stack/Profiler/FFI.hs +96/−0
- src/GHC/Stack/Profiler/Manager.hs +100/−0
- src/GHC/Stack/Profiler/Sampler.hs +0/−180
- src/GHC/Stack/Profiler/Stack/Compat.hs +2/−3
- src/GHC/Stack/Profiler/Stack/Decode.hs +30/−25
- src/GHC/Stack/Profiler/SymbolTable.hs +37/−0
- src/GHC/Stack/Profiler/Util.hs +1/−1
CHANGELOG.md view
@@ -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.
cbits/Stack.cmm view
@@ -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)
ghc-stack-profiler.cabal view
@@ -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
src/Debug/Trace/Binary/Compat.hs view
@@ -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
src/GHC/Internal/Heap/Closures/Compat.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-}+ module GHC.Internal.Heap.Closures.Compat (- Box(..),+ Box (..), ) where #if MIN_VERSION_ghc_internal(9,1400,0)
src/GHC/Internal/Stack/Constants/Compat.hs view
@@ -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-
src/GHC/Internal/Stack/Decode/Compat.hs view
@@ -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
src/GHC/Stack/Annotation/Experimental/Compat.hs view
@@ -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)
+ src/GHC/Stack/Profiler.hs view
@@ -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+ ]
+ src/GHC/Stack/Profiler/Commands.hs view
@@ -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
src/GHC/Stack/Profiler/Decode.hs view
@@ -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+ }
+ src/GHC/Stack/Profiler/FFI.hs view
@@ -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
+ src/GHC/Stack/Profiler/Manager.hs view
@@ -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
− src/GHC/Stack/Profiler/Sampler.hs
@@ -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
src/GHC/Stack/Profiler/Stack/Compat.hs view
@@ -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--
src/GHC/Stack/Profiler/Stack/Decode.hs view
@@ -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
+ src/GHC/Stack/Profiler/SymbolTable.hs view
@@ -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
src/GHC/Stack/Profiler/Util.hs view
@@ -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