diff options
Diffstat (limited to 'libraries/base')
| -rw-r--r-- | libraries/base/GHC/Stack/CCS.hsc | 68 | ||||
| -rw-r--r-- | libraries/base/GHC/Stack/CloneStack.hs | 136 | ||||
| -rw-r--r-- | libraries/base/base.cabal | 1 | ||||
| -rw-r--r-- | libraries/base/cbits/StackCloningDecoding.cmm | 26 |
4 files changed, 194 insertions, 37 deletions
diff --git a/libraries/base/GHC/Stack/CCS.hsc b/libraries/base/GHC/Stack/CCS.hsc index 67e50ae9a1..a8af10a1a1 100644 --- a/libraries/base/GHC/Stack/CCS.hsc +++ b/libraries/base/GHC/Stack/CCS.hsc @@ -34,7 +34,11 @@ module GHC.Stack.CCS ( ccModule, ccSrcSpan, ccsToStrings, - renderStack + renderStack, + ipeProv, + peekInfoProv, + InfoProv(..), + InfoProvEnt, ) where import Foreign @@ -45,6 +49,7 @@ import GHC.Ptr import GHC.Foreign as GHC import GHC.IO.Encoding import GHC.List ( concatMap, reverse ) +import GHC.Show (Show) #define PROFILING #include "Rts.h" @@ -139,7 +144,14 @@ renderStack strs = -- Static Closure Information -data InfoProv +data InfoProv = InfoProv { + ipName :: String, + ipDesc :: String, + ipTyDesc :: String, + ipLabel :: String, + ipMod :: String, + ipLoc :: String +} deriving (Eq, Show) data InfoProvEnt getIPE :: a -> IO (Ptr InfoProvEnt) @@ -150,25 +162,31 @@ getIPE obj = IO $ \s -> ipeProv :: Ptr InfoProvEnt -> Ptr InfoProv ipeProv p = (#ptr InfoProvEnt, prov) p -ipName, ipDesc, ipLabel, ipModule, ipSrcLoc, ipTyDesc :: Ptr InfoProv -> IO CString -ipName p = (# peek InfoProv, table_name) p -ipDesc p = (# peek InfoProv, closure_desc) p -ipLabel p = (# peek InfoProv, label) p -ipModule p = (# peek InfoProv, module) p -ipSrcLoc p = (# peek InfoProv, srcloc) p -ipTyDesc p = (# peek InfoProv, ty_desc) p - -infoProvToStrings :: Ptr InfoProv -> IO [String] -infoProvToStrings infop = do - name <- GHC.peekCString utf8 =<< ipName infop - desc <- GHC.peekCString utf8 =<< ipDesc infop - ty_desc <- GHC.peekCString utf8 =<< ipTyDesc infop - label <- GHC.peekCString utf8 =<< ipLabel infop - mod <- GHC.peekCString utf8 =<< ipModule infop - loc <- GHC.peekCString utf8 =<< ipSrcLoc infop - return [name, desc, ty_desc, label, mod, loc] - --- TODO: Add structured output of whereFrom +peekIpName, peekIpDesc, peekIpLabel, peekIpModule, peekIpSrcLoc, peekIpTyDesc :: Ptr InfoProv -> IO CString +peekIpName p = (# peek InfoProv, table_name) p +peekIpDesc p = (# peek InfoProv, closure_desc) p +peekIpLabel p = (# peek InfoProv, label) p +peekIpModule p = (# peek InfoProv, module) p +peekIpSrcLoc p = (# peek InfoProv, srcloc) p +peekIpTyDesc p = (# peek InfoProv, ty_desc) p + +peekInfoProv :: Ptr InfoProv -> IO InfoProv +peekInfoProv infop = do + name <- GHC.peekCString utf8 =<< peekIpName infop + desc <- GHC.peekCString utf8 =<< peekIpDesc infop + tyDesc <- GHC.peekCString utf8 =<< peekIpTyDesc infop + label <- GHC.peekCString utf8 =<< peekIpLabel infop + mod <- GHC.peekCString utf8 =<< peekIpModule infop + loc <- GHC.peekCString utf8 =<< peekIpSrcLoc infop + return InfoProv { + ipName = name, + ipDesc = desc, + ipTyDesc = tyDesc, + ipLabel = label, + ipMod = mod, + ipLoc = loc + } + -- | Get information about where a value originated from. -- This information is stored statically in a binary when `-finfo-table-map` is -- enabled. The source positions will be greatly improved by also enabled debug @@ -178,7 +196,7 @@ infoProvToStrings infop = do -- The information is collect by looking at the info table address of a specific closure and -- then consulting a specially generated map (by `-finfo-table-map`) to find out where we think -- the best source position to describe that info table arose from. -whereFrom :: a -> IO [String] +whereFrom :: a -> IO (Maybe InfoProv) whereFrom obj = do ipe <- getIPE obj -- The primop returns the null pointer in two situations at the moment @@ -186,5 +204,7 @@ whereFrom obj = do -- 2. -finfo-table-map is not enabled. -- It would be good to distinguish between these two cases somehow. if ipe == nullPtr - then return [] - else infoProvToStrings (ipeProv ipe) + then return Nothing + else do + infoProv <- peekInfoProv (ipeProv ipe) + return $ Just infoProv diff --git a/libraries/base/GHC/Stack/CloneStack.hs b/libraries/base/GHC/Stack/CloneStack.hs index 68077d4299..f06ecad070 100644 --- a/libraries/base/GHC/Stack/CloneStack.hs +++ b/libraries/base/GHC/Stack/CloneStack.hs @@ -1,31 +1,47 @@ {-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedFFITypes#-} +{-# LANGUAGE GHCForeignImportPrim #-} -- | -- This module exposes an interface for capturing the state of a thread's --- execution stack for diagnostics purposes. +-- execution stack for diagnostics purposes: 'cloneMyStack', +-- 'cloneThreadStack'. +-- +-- Such a "cloned" stack can be decoded with 'decode' to a stack trace, given +-- that the @-finfo-table-map@ is enabled. -- -- @since 2.16.0.0 module GHC.Stack.CloneStack ( StackSnapshot(..), + StackEntry(..), cloneMyStack, - cloneThreadStack + cloneThreadStack, + decode ) where -import GHC.Prim (StackSnapshot#, cloneMyStack#, ThreadId#) import Control.Concurrent.MVar +import Data.Maybe (catMaybes) +import Foreign import GHC.Conc.Sync +import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#) +import GHC.IO (IO (..)) +import GHC.Stack.CCS (InfoProv (..), InfoProvEnt, ipeProv, peekInfoProv) import GHC.Stable -import GHC.IO (IO(..)) -- | A frozen snapshot of the state of an execution stack. -- -- @since 2.16.0.0 data StackSnapshot = StackSnapshot !StackSnapshot# +foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, Array# (Ptr InfoProvEnt) #) + +foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #) + +foreign import prim "stg_sendCloneStackMessagezh" sendCloneStackMessage# :: ThreadId# -> StablePtr# PrimMVar -> State# RealWorld -> (# State# RealWorld, (# #) #) + {- Note [Stack Cloning] ~~~~~~~~~~~~~~~~~~~~ @@ -55,8 +71,9 @@ or `StablePtr`: - `StablePtr` has to be freed explictly, which would introduce nasty state handling. -By using a primitive type, the stack closure is kept and managed by the garbage -collector as long as it's in use and automatically freed later. +By using a primitive type, the stack closure (and its transitive closures) is +kept and managed by the garbage collector as long as it's in use and +automatically freed later. As closures referred to by stack closures (e.g. payloads) may be used by other closures that are not related to stack cloning, the memory has to be managed by the garbage collector; i.e. one cannot simply call free() in the RTS C code @@ -67,7 +84,7 @@ RTS interface ------------- There are two different ways to clone a stack: 1. `cloneMyStack#` - A primop for cloning the active thread's stack. -2. `sendCloneStackMessage` - A FFI function for cloning another thread's stack. +2. `sendCloneStackMessage#` - A primop for cloning another thread's stack. Sends a RTS message (Messages.c) with a MVar to that thread. The cloned stack is reveived by taking it out of this MVar. @@ -130,6 +147,39 @@ function that dispatches messages is `executeMessage`. From there (`msg->mvar`). -} +{- +Note [Stack Decoding] +~~~~~~~~~~~~~~~~~~~~~ +A cloned stack is decoded (unwound) by looking up the Info Table Provenance +Entries (IPE) for every stack frame with `lookupIPE` in the RTS. + +The IPEs contain source locations and are pulled from the RTS/C world into +Haskell. + +RTS interface +------------- + +The primop decodeStack# returns an array of IPE pointers that are later +unmarshalled with HSC. If there is no IPE for a return frame (which can easily +happen when a library wasn't compiled with `-finfo-table-map`), it's +represented by a null pointer. + +Caveats: +- decodeStack# has to be a primop (not a simple C FFI function), because + there always has to be at least one active `TSO`. Otherwise, allocating + memory with the garbage collector for the returned value fails. +- decodeStack# has to be defined outside of `primops.txt.pp` because its + return type `Array# (Ptr InfoProvEnt)` cannot be defined there: + `InfoProvEnt` and `Ptr` would have to be imported which seems to be too + specific for this file. + +Notes +----- +The relevant notes are: + - Note [Mapping Info Tables to Source Positions] + - Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] +-} + -- | Clone the stack of the executing thread -- -- @since 2.16.0.0 @@ -137,18 +187,78 @@ cloneMyStack :: IO StackSnapshot cloneMyStack = IO $ \s -> case (cloneMyStack# s) of (# s1, stack #) -> (# s1, StackSnapshot stack #) -foreign import ccall "sendCloneStackMessage" sendCloneStackMessage :: ThreadId# -> StablePtr PrimMVar -> IO () - -- | Clone the stack of a thread identified by its 'ThreadId' -- -- @since 2.16.0.0 cloneThreadStack :: ThreadId -> IO StackSnapshot cloneThreadStack (ThreadId tid#) = do resultVar <- newEmptyMVar @StackSnapshot - ptr <- newStablePtrPrimMVar resultVar + boxedPtr@(StablePtr ptr) <- newStablePtrPrimMVar resultVar -- Use the RTS's "message" mechanism to request that -- the thread captures its stack, saving the result -- into resultVar. - sendCloneStackMessage tid# ptr - freeStablePtr ptr + IO $ \s -> case sendCloneStackMessage# tid# ptr s of (# s', (# #) #) -> (# s', () #) + freeStablePtr boxedPtr takeMVar resultVar + +-- | Represetation for the source location where a return frame was pushed on the stack. +-- This happens every time when a @case ... of@ scrutinee is evaluated. +data StackEntry = StackEntry + { functionName :: String, + moduleName :: String, + srcLoc :: String, + closureType :: Word + } + deriving (Show, Eq) + +-- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry'). +-- The stack trace is created from return frames with according 'InfoProvEnt' +-- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are +-- no 'InfoProvEnt' entries, an empty list is returned. +-- +-- Please note: +-- +-- * To gather 'StackEntry' from libraries, these have to be +-- compiled with @-finfo-table-map@, too. +-- * Due to optimizations by GHC (e.g. inlining) the stacktrace may change +-- with different GHC parameters and versions. +-- * The stack trace is empty (by design) if there are no return frames on +-- the stack. (These are pushed every time when a @case ... of@ scrutinee +-- is evaluated.) +-- +-- @since 2.16.0.0 +decode :: StackSnapshot -> IO [StackEntry] +decode stackSnapshot = do + stackEntries <- getDecodedStackArray stackSnapshot + ipes <- mapM unmarshall stackEntries + return $ catMaybes ipes + + where + unmarshall :: Ptr InfoProvEnt -> IO (Maybe StackEntry) + unmarshall ipe = if ipe == nullPtr then + pure Nothing + else do + infoProv <- (peekInfoProv . ipeProv) ipe + pure $ Just (toStackEntry infoProv) + toStackEntry :: InfoProv -> StackEntry + toStackEntry infoProv = + StackEntry + { functionName = ipLabel infoProv, + moduleName = ipMod infoProv, + srcLoc = ipLoc infoProv, + -- read looks dangerous, be we can trust that the closure type is always there. + closureType = read . ipDesc $ infoProv + } + +getDecodedStackArray :: StackSnapshot -> IO [Ptr InfoProvEnt] +getDecodedStackArray (StackSnapshot s) = + IO $ \s0 -> case decodeStack# s s0 of + (# s1, a #) -> (# s1, (go a ((I# (sizeofArray# a)) - 1)) #) + where + go :: Array# (Ptr InfoProvEnt) -> Int -> [Ptr InfoProvEnt] + go stack 0 = [stackEntryAt stack 0] + go stack i = (stackEntryAt stack i) : go stack (i - 1) + + stackEntryAt :: Array# (Ptr InfoProvEnt) -> Int -> Ptr InfoProvEnt + stackEntryAt stack (I# i) = case indexArray# stack i of + (# se #) -> se diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 90ab51c214..0f7023ae79 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -352,6 +352,7 @@ Library cmm-sources: cbits/CastFloatWord.cmm + cbits/StackCloningDecoding.cmm include-dirs: include includes: diff --git a/libraries/base/cbits/StackCloningDecoding.cmm b/libraries/base/cbits/StackCloningDecoding.cmm new file mode 100644 index 0000000000..17b71dd0f0 --- /dev/null +++ b/libraries/base/cbits/StackCloningDecoding.cmm @@ -0,0 +1,26 @@ +#include "Cmm.h" + +stg_cloneMyStackzh () { + gcptr stgStack; + gcptr clonedStack; + + stgStack = StgTSO_stackobj(CurrentTSO); + StgStack_sp(stgStack) = Sp; + + ("ptr" clonedStack) = ccall cloneStack(MyCapability() "ptr", stgStack "ptr"); + + return (clonedStack); +} + +stg_sendCloneStackMessagezh (gcptr threadId, gcptr mVarStablePtr) { + ccall sendCloneStackMessage(threadId "ptr", mVarStablePtr "ptr"); + + return (); +} + +stg_decodeStackzh (gcptr stgStack) { + gcptr stackEntries; + ("ptr" stackEntries) = ccall decodeClonedStack(MyCapability() "ptr", stgStack "ptr"); + + return (stackEntries); +} |