{-# LINE 1 "libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc" #-}
{-# LANGUAGE MultiWayIf #-}
module GHC.Internal.ExecutionStack.Internal (
Location (..)
, showLocation
, SrcLoc (..)
, StackTrace
, stackFrames
, stackDepth
, collectStackTrace
, showStackFrames
, invalidateDebugCache
) where
import GHC.Internal.Data.Functor
import GHC.Internal.Data.Maybe
import GHC.Internal.Data.List (reverse, null)
import GHC.Internal.Word
import GHC.Internal.Foreign.C.Types
import GHC.Internal.Foreign.C.String (peekCString, CString)
import GHC.Internal.Foreign.Ptr (Ptr, nullPtr, castPtr, plusPtr, FunPtr)
import GHC.Internal.Foreign.ForeignPtr
import GHC.Internal.Foreign.Marshal.Alloc (allocaBytes)
import GHC.Internal.Foreign.Storable (Storable(..))
import GHC.Internal.Base
import GHC.Internal.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO)
import GHC.Internal.Num
import GHC.Internal.Real
import GHC.Internal.Text.Show
data SrcLoc = SrcLoc { SrcLoc -> String
sourceFile :: String
, SrcLoc -> Int
sourceLine :: Int
, SrcLoc -> Int
sourceColumn :: Int
}
data Location = Location { Location -> String
objectName :: String
, Location -> String
functionName :: String
, Location -> Maybe SrcLoc
srcLoc :: Maybe SrcLoc
}
data Chunk = Chunk { Chunk -> Word
chunkFrames :: !Word
, Chunk -> Ptr Chunk
chunkNext :: !(Ptr Chunk)
, Chunk -> Ptr Addr
chunkFirstFrame :: !(Ptr Addr)
}
newtype StackTrace = StackTrace (ForeignPtr StackTrace)
type Addr = Ptr ()
withSession :: (ForeignPtr Session -> IO a) -> IO (Maybe a)
withSession :: forall a. (ForeignPtr Session -> IO a) -> IO (Maybe a)
withSession ForeignPtr Session -> IO a
action = do
ptr <- IO (Ptr Session)
libdw_pool_take
if | nullPtr == ptr -> return Nothing
| otherwise -> do
fptr <- newForeignPtr libdw_pool_release ptr
ret <- action fptr
return $ Just ret
stackDepth :: StackTrace -> Int
stackDepth :: StackTrace -> Int
stackDepth (StackTrace ForeignPtr StackTrace
fptr) =
IO Int -> Int
forall a. IO a -> a
unsafePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$ ForeignPtr StackTrace -> (Ptr StackTrace -> IO Int) -> IO Int
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StackTrace
fptr ((Ptr StackTrace -> IO Int) -> IO Int)
-> (Ptr StackTrace -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr StackTrace
ptr ->
Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> (Word -> Word) -> Word -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word
asWord (Word -> Int) -> IO Word -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((\Ptr StackTrace
hsc_ptr -> Ptr StackTrace -> Int -> IO Word
forall b. Ptr b -> Int -> IO Word
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr StackTrace
hsc_ptr Int
0)) Ptr StackTrace
ptr
{-# LINE 96 "libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc" #-}
where
asWord :: Word -> Word
asWord = Word -> Word
forall a. a -> a
id :: Word -> Word
peekChunk :: Ptr Chunk -> IO Chunk
peekChunk :: Ptr Chunk -> IO Chunk
peekChunk Ptr Chunk
ptr =
Word -> Ptr Chunk -> Ptr Addr -> Chunk
Chunk (Word -> Ptr Chunk -> Ptr Addr -> Chunk)
-> IO Word -> IO (Ptr Chunk -> Ptr Addr -> Chunk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((\Ptr Chunk
hsc_ptr -> Ptr Chunk -> Int -> IO Word
forall b. Ptr b -> Int -> IO Word
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Chunk
hsc_ptr Int
0)) Ptr Chunk
ptr
{-# LINE 102 "libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc" #-}
IO (Ptr Chunk -> Ptr Addr -> Chunk)
-> IO (Ptr Chunk) -> IO (Ptr Addr -> Chunk)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((\Ptr Chunk
hsc_ptr -> Ptr Chunk -> Int -> IO (Ptr Chunk)
forall b. Ptr b -> Int -> IO (Ptr Chunk)
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Chunk
hsc_ptr Int
8)) Ptr Chunk
ptr
{-# LINE 103 "libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc" #-}
IO (Ptr Addr -> Chunk) -> IO (Ptr Addr) -> IO Chunk
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr Addr -> IO (Ptr Addr)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr Any -> Ptr Addr
forall a b. Ptr a -> Ptr b
castPtr (Ptr Any -> Ptr Addr) -> Ptr Any -> Ptr Addr
forall a b. (a -> b) -> a -> b
$ ((\Ptr Chunk
hsc_ptr -> Ptr Chunk
hsc_ptr Ptr Chunk -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
16)) Ptr Chunk
ptr)
{-# LINE 104 "libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc" #-}
chunksList :: StackTrace -> IO [Chunk]
chunksList :: StackTrace -> IO [Chunk]
chunksList (StackTrace ForeignPtr StackTrace
fptr) = ForeignPtr StackTrace
-> (Ptr StackTrace -> IO [Chunk]) -> IO [Chunk]
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StackTrace
fptr ((Ptr StackTrace -> IO [Chunk]) -> IO [Chunk])
-> (Ptr StackTrace -> IO [Chunk]) -> IO [Chunk]
forall a b. (a -> b) -> a -> b
$ \Ptr StackTrace
ptr ->
[Chunk] -> Ptr Chunk -> IO [Chunk]
go [] (Ptr Chunk -> IO [Chunk]) -> IO (Ptr Chunk) -> IO [Chunk]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((\Ptr StackTrace
hsc_ptr -> Ptr StackTrace -> Int -> IO (Ptr Chunk)
forall b. Ptr b -> Int -> IO (Ptr Chunk)
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr StackTrace
hsc_ptr Int
8)) Ptr StackTrace
ptr
{-# LINE 110 "libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc" #-}
where
go :: [Chunk] -> Ptr Chunk -> IO [Chunk]
go [Chunk]
accum Ptr Chunk
ptr
| Ptr Chunk
ptr Ptr Chunk -> Ptr Chunk -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Chunk
forall a. Ptr a
nullPtr = [Chunk] -> IO [Chunk]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Chunk]
accum
| Bool
otherwise = do
chunk <- Ptr Chunk -> IO Chunk
peekChunk Ptr Chunk
ptr
go (chunk : accum) (chunkNext chunk)
peekLocation :: Ptr Location -> IO Location
peekLocation :: Ptr Location -> IO Location
peekLocation Ptr Location
ptr = do
let peekCStringPtr :: CString -> IO String
peekCStringPtr :: CString -> IO String
peekCStringPtr CString
p
| CString
p CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
/= CString
forall a. Ptr a
nullPtr = CString -> IO String
peekCString (CString -> IO String) -> CString -> IO String
forall a b. (a -> b) -> a -> b
$ CString -> CString
forall a b. Ptr a -> Ptr b
castPtr CString
p
| Bool
otherwise = String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
objFile <- CString -> IO String
peekCStringPtr (CString -> IO String) -> IO CString -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((\Ptr Location
hsc_ptr -> Ptr Location -> Int -> IO CString
forall b. Ptr b -> Int -> IO CString
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Location
hsc_ptr Int
0)) Ptr Location
ptr
{-# LINE 125 "libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc" #-}
function <- peekCStringPtr =<< ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
{-# LINE 126 "libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc" #-}
srcFile <- peekCStringPtr =<< ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr
{-# LINE 127 "libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc" #-}
lineNo <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr :: IO Word32
{-# LINE 128 "libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc" #-}
colNo <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) ptr :: IO Word32
{-# LINE 129 "libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc" #-}
let _srcLoc
| null srcFile = Nothing
| otherwise = Just $ SrcLoc { sourceFile = srcFile
, sourceLine = fromIntegral lineNo
, sourceColumn = fromIntegral colNo
}
return Location { objectName = objFile
, functionName = function
, srcLoc = _srcLoc
}
locationSize :: Int
locationSize :: Int
locationSize = (Int
32)
{-# LINE 143 "libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc" #-}
stackFrames :: StackTrace -> Maybe [Location]
stackFrames :: StackTrace -> Maybe [Location]
stackFrames st :: StackTrace
st@(StackTrace ForeignPtr StackTrace
fptr) = IO (Maybe [Location]) -> Maybe [Location]
forall a. IO a -> a
unsafePerformIO (IO (Maybe [Location]) -> Maybe [Location])
-> IO (Maybe [Location]) -> Maybe [Location]
forall a b. (a -> b) -> a -> b
$ (ForeignPtr Session -> IO [Location]) -> IO (Maybe [Location])
forall a. (ForeignPtr Session -> IO a) -> IO (Maybe a)
withSession ((ForeignPtr Session -> IO [Location]) -> IO (Maybe [Location]))
-> (ForeignPtr Session -> IO [Location]) -> IO (Maybe [Location])
forall a b. (a -> b) -> a -> b
$ \ForeignPtr Session
sess -> do
chunks <- StackTrace -> IO [Chunk]
chunksList StackTrace
st
go sess (reverse chunks)
where
go :: ForeignPtr Session -> [Chunk] -> IO [Location]
go :: ForeignPtr Session -> [Chunk] -> IO [Location]
go ForeignPtr Session
_ [] = [Location] -> IO [Location]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
go ForeignPtr Session
sess (Chunk
chunk : [Chunk]
chunks) = do
this <- ForeignPtr Session -> Chunk -> IO [Location]
iterChunk ForeignPtr Session
sess Chunk
chunk
rest <- unsafeInterleaveIO (go sess chunks)
return (this ++ rest)
iterChunk :: ForeignPtr Session -> Chunk -> IO [Location]
iterChunk :: ForeignPtr Session -> Chunk -> IO [Location]
iterChunk ForeignPtr Session
sess Chunk
chunk = Word -> Ptr Addr -> IO [Location]
iterFrames (Chunk -> Word
chunkFrames Chunk
chunk) (Chunk -> Ptr Addr
chunkFirstFrame Chunk
chunk)
where
iterFrames :: Word -> Ptr Addr -> IO [Location]
iterFrames :: Word -> Ptr Addr -> IO [Location]
iterFrames Word
0 Ptr Addr
_ = [Location] -> IO [Location]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
iterFrames Word
n Ptr Addr
frame = do
pc <- Ptr Addr -> IO Addr
forall a. Storable a => Ptr a -> IO a
peek Ptr Addr
frame :: IO Addr
mframe <- lookupFrame pc
rest <- unsafeInterleaveIO (iterFrames (n-1) frame')
return $ maybe rest (:rest) mframe
where
frame' :: Ptr b
frame' = Ptr Addr
frame Ptr Addr -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Addr -> Int
forall a. Storable a => a -> Int
sizeOf (Addr
forall a. HasCallStack => a
undefined :: Addr)
lookupFrame :: Addr -> IO (Maybe Location)
lookupFrame :: Addr -> IO (Maybe Location)
lookupFrame Addr
pc = ForeignPtr StackTrace
-> (Ptr StackTrace -> IO (Maybe Location)) -> IO (Maybe Location)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StackTrace
fptr ((Ptr StackTrace -> IO (Maybe Location)) -> IO (Maybe Location))
-> (Ptr StackTrace -> IO (Maybe Location)) -> IO (Maybe Location)
forall a b. (a -> b) -> a -> b
$ IO (Maybe Location) -> Ptr StackTrace -> IO (Maybe Location)
forall a b. a -> b -> a
const (IO (Maybe Location) -> Ptr StackTrace -> IO (Maybe Location))
-> IO (Maybe Location) -> Ptr StackTrace -> IO (Maybe Location)
forall a b. (a -> b) -> a -> b
$
Int -> (Ptr Location -> IO (Maybe Location)) -> IO (Maybe Location)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
locationSize ((Ptr Location -> IO (Maybe Location)) -> IO (Maybe Location))
-> (Ptr Location -> IO (Maybe Location)) -> IO (Maybe Location)
forall a b. (a -> b) -> a -> b
$ \Ptr Location
buf -> do
ret <- ForeignPtr Session -> (Ptr Session -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Session
sess ((Ptr Session -> IO CInt) -> IO CInt)
-> (Ptr Session -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \Ptr Session
sessPtr -> Ptr Session -> Ptr Location -> Addr -> IO CInt
libdw_lookup_location Ptr Session
sessPtr Ptr Location
buf Addr
pc
case ret of
CInt
0 -> Location -> Maybe Location
forall a. a -> Maybe a
Just (Location -> Maybe Location) -> IO Location -> IO (Maybe Location)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Location -> IO Location
peekLocation Ptr Location
buf
CInt
_ -> Maybe Location -> IO (Maybe Location)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Location
forall a. Maybe a
Nothing
data Session
foreign import ccall unsafe "libdwPoolTake"
libdw_pool_take :: IO (Ptr Session)
foreign import ccall unsafe "&libdwPoolRelease"
libdw_pool_release :: FunPtr (Ptr Session -> IO ())
foreign import ccall unsafe "libdwPoolClear"
libdw_pool_clear :: IO ()
foreign import ccall unsafe "libdwLookupLocation"
libdw_lookup_location :: Ptr Session -> Ptr Location -> Addr -> IO CInt
foreign import ccall unsafe "libdwGetBacktrace"
libdw_get_backtrace :: Ptr Session -> IO (Ptr StackTrace)
foreign import ccall unsafe "&backtraceFree"
backtrace_free :: FunPtr (Ptr StackTrace -> IO ())
collectStackTrace :: IO (Maybe StackTrace)
collectStackTrace :: IO (Maybe StackTrace)
collectStackTrace = (Maybe (Maybe StackTrace) -> Maybe StackTrace)
-> IO (Maybe (Maybe StackTrace)) -> IO (Maybe StackTrace)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe StackTrace) -> Maybe StackTrace
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (Maybe (Maybe StackTrace)) -> IO (Maybe StackTrace))
-> IO (Maybe (Maybe StackTrace)) -> IO (Maybe StackTrace)
forall a b. (a -> b) -> a -> b
$ (ForeignPtr Session -> IO (Maybe StackTrace))
-> IO (Maybe (Maybe StackTrace))
forall a. (ForeignPtr Session -> IO a) -> IO (Maybe a)
withSession ((ForeignPtr Session -> IO (Maybe StackTrace))
-> IO (Maybe (Maybe StackTrace)))
-> (ForeignPtr Session -> IO (Maybe StackTrace))
-> IO (Maybe (Maybe StackTrace))
forall a b. (a -> b) -> a -> b
$ \ForeignPtr Session
sess -> do
st <- ForeignPtr Session
-> (Ptr Session -> IO (Ptr StackTrace)) -> IO (Ptr StackTrace)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Session
sess Ptr Session -> IO (Ptr StackTrace)
libdw_get_backtrace
if | st == nullPtr -> return Nothing
| otherwise -> Just . StackTrace <$> newForeignPtr backtrace_free st
invalidateDebugCache :: IO ()
invalidateDebugCache :: IO ()
invalidateDebugCache = IO ()
libdw_pool_clear
showStackFrames :: [Location] -> ShowS
showStackFrames :: [Location] -> ShowS
showStackFrames [Location]
frames =
String -> ShowS
showString String
"Stack trace:\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id ((Location -> ShowS) -> [Location] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map Location -> ShowS
showFrame [Location]
frames)
where
showFrame :: Location -> ShowS
showFrame Location
loc =
String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> ShowS
showLocation Location
loc ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\n'
showLocation :: Location -> ShowS
showLocation :: Location -> ShowS
showLocation Location
loc =
String -> ShowS
showString (Location -> String
functionName Location
loc)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> (SrcLoc -> ShowS) -> Maybe SrcLoc -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowS
forall a. a -> a
id SrcLoc -> ShowS
showSrcLoc (Location -> Maybe SrcLoc
srcLoc Location
loc)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" in "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Location -> String
objectName Location
loc)
where
showSrcLoc :: SrcLoc -> ShowS
showSrcLoc :: SrcLoc -> ShowS
showSrcLoc SrcLoc
sloc =
String -> ShowS
showString String
" ("
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (SrcLoc -> String
sourceFile SrcLoc
sloc)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
":"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows (SrcLoc -> Int
sourceLine SrcLoc
sloc)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"."
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows (SrcLoc -> Int
sourceColumn SrcLoc
sloc)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")"