{-# LINE 1 "libraries/base/GHC/ExecutionStack/Internal.hsc" #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.ExecutionStack.Internal
-- Copyright   :  (c) The University of Glasgow 2013-2015
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- Internals of the `GHC.ExecutionStack` module
--
-- @since 4.9.0.0
-----------------------------------------------------------------------------





{-# LANGUAGE MultiWayIf #-}

module GHC.ExecutionStack.Internal (
  -- * Internal
    Location (..)
  , SrcLoc (..)
  , StackTrace
  , stackFrames
  , stackDepth
  , collectStackTrace
  , showStackFrames
  , invalidateDebugCache
  ) where

import Control.Monad (join)
import Data.Word
import Foreign.C.Types
import Foreign.C.String (peekCString, CString)
import Foreign.Ptr (Ptr, nullPtr, castPtr, plusPtr, FunPtr)
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Storable (Storable(..))
import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO)

-- N.B. See includes/rts/Libdw.h for notes on stack representation.

-- | A location in the original program source.
data SrcLoc = SrcLoc { SrcLoc -> String
sourceFile   :: String
                     , SrcLoc -> Int
sourceLine   :: Int
                     , SrcLoc -> Int
sourceColumn :: Int
                     }

-- | Location information about an address from a backtrace.
data Location = Location { Location -> String
objectName   :: String
                         , Location -> String
functionName :: String
                         , Location -> Maybe SrcLoc
srcLoc       :: Maybe SrcLoc
                         }

-- | A chunk of backtrace frames
data Chunk = Chunk { Chunk -> Word
chunkFrames     :: !Word
                   , Chunk -> Ptr Chunk
chunkNext       :: !(Ptr Chunk)
                   , Chunk -> Ptr Addr
chunkFirstFrame :: !(Ptr Addr)
                   }

-- | The state of the execution stack
newtype StackTrace = StackTrace (ForeignPtr StackTrace)

-- | An address
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 Session
ptr <- IO (Ptr Session)
libdw_pool_take
    if | forall a. Ptr a
nullPtr forall a. Eq a => a -> a -> Bool
== Ptr Session
ptr -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
       | Bool
otherwise      -> do
           ForeignPtr Session
fptr <- forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FunPtr (Ptr Session -> IO ())
libdw_pool_release Ptr Session
ptr
           a
ret <- ForeignPtr Session -> IO a
action ForeignPtr Session
fptr
           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
ret

-- | How many stack frames in the given 'StackTrace'
stackDepth :: StackTrace -> Int
stackDepth :: StackTrace -> Int
stackDepth (StackTrace ForeignPtr StackTrace
fptr) =
    forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StackTrace
fptr forall a b. (a -> b) -> a -> b
$ \Ptr StackTrace
ptr ->
        forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word
asWord forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((\Ptr StackTrace
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr StackTrace
hsc_ptr Int
0)) Ptr StackTrace
ptr
{-# LINE 84 "libraries/base/GHC/ExecutionStack/Internal.hsc" #-}
  where
    asWord :: Word -> Word
asWord = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((\Ptr Chunk
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Chunk
hsc_ptr Int
0)) Ptr Chunk
ptr
{-# LINE 90 "libraries/base/GHC/ExecutionStack/Internal.hsc" #-}
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((\Ptr Chunk
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Chunk
hsc_ptr Int
8)) Ptr Chunk
ptr
{-# LINE 91 "libraries/base/GHC/ExecutionStack/Internal.hsc" #-}
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. Ptr a -> Ptr b
castPtr forall a b. (a -> b) -> a -> b
$ ((\Ptr Chunk
hsc_ptr -> Ptr Chunk
hsc_ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
16)) Ptr Chunk
ptr)
{-# LINE 92 "libraries/base/GHC/ExecutionStack/Internal.hsc" #-}

-- | Return a list of the chunks of a backtrace, from the outer-most to
-- inner-most chunk.
chunksList :: StackTrace -> IO [Chunk]
chunksList :: StackTrace -> IO [Chunk]
chunksList (StackTrace ForeignPtr StackTrace
fptr) = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StackTrace
fptr forall a b. (a -> b) -> a -> b
$ \Ptr StackTrace
ptr ->
    [Chunk] -> Ptr Chunk -> IO [Chunk]
go [] forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((\Ptr StackTrace
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr StackTrace
hsc_ptr Int
8)) Ptr StackTrace
ptr
{-# LINE 98 "libraries/base/GHC/ExecutionStack/Internal.hsc" #-}
  where
    go :: [Chunk] -> Ptr Chunk -> IO [Chunk]
go [Chunk]
accum Ptr Chunk
ptr
      | Ptr Chunk
ptr forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr = forall (m :: * -> *) a. Monad m => a -> m a
return [Chunk]
accum
      | Bool
otherwise = do
            Chunk
chunk <- Ptr Chunk -> IO Chunk
peekChunk Ptr Chunk
ptr
            [Chunk] -> Ptr Chunk -> IO [Chunk]
go (Chunk
chunk forall a. a -> [a] -> [a]
: [Chunk]
accum) (Chunk -> Ptr Chunk
chunkNext Chunk
chunk)

-- | Unpack the given 'Location' in the Haskell representation
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 forall a. Eq a => a -> a -> Bool
/= forall a. Ptr a
nullPtr = CString -> IO String
peekCString forall a b. (a -> b) -> a -> b
$ forall a b. Ptr a -> Ptr b
castPtr CString
p
          | Bool
otherwise    = forall (m :: * -> *) a. Monad m => a -> m a
return String
""
    String
objFile <- CString -> IO String
peekCStringPtr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((\Ptr Location
hsc_ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Location
hsc_ptr Int
0)) Ptr Location
ptr
{-# LINE 113 "libraries/base/GHC/ExecutionStack/Internal.hsc" #-}
    function <- peekCStringPtr =<< ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
{-# LINE 114 "libraries/base/GHC/ExecutionStack/Internal.hsc" #-}
    srcFile <- peekCStringPtr =<< ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr
{-# LINE 115 "libraries/base/GHC/ExecutionStack/Internal.hsc" #-}
    lineNo <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr :: IO Word32
{-# LINE 116 "libraries/base/GHC/ExecutionStack/Internal.hsc" #-}
    colNo <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) ptr :: IO Word32
{-# LINE 117 "libraries/base/GHC/ExecutionStack/Internal.hsc" #-}
    let _srcLoc
          | null srcFile = Nothing
          | otherwise = Just $ SrcLoc { sourceFile = srcFile
                                      , sourceLine = fromIntegral lineNo
                                      , sourceColumn = fromIntegral colNo
                                      }
    forall (m :: * -> *) a. Monad m => a -> m a
return Location { objectName :: String
objectName = String
objFile
                    , functionName :: String
functionName = String
function
                    , srcLoc :: Maybe SrcLoc
srcLoc = Maybe SrcLoc
_srcLoc
                    }

-- | The size in bytes of a 'locationSize'
locationSize :: Int
locationSize :: Int
locationSize = (Int
32)
{-# LINE 131 "libraries/base/GHC/ExecutionStack/Internal.hsc" #-}

-- | List the frames of a stack trace.
stackFrames :: StackTrace -> Maybe [Location]
stackFrames :: StackTrace -> Maybe [Location]
stackFrames st :: StackTrace
st@(StackTrace ForeignPtr StackTrace
fptr) = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. (ForeignPtr Session -> IO a) -> IO (Maybe a)
withSession forall a b. (a -> b) -> a -> b
$ \ForeignPtr Session
sess -> do
    [Chunk]
chunks <- StackTrace -> IO [Chunk]
chunksList StackTrace
st
    ForeignPtr Session -> [Chunk] -> IO [Location]
go ForeignPtr Session
sess (forall a. [a] -> [a]
reverse [Chunk]
chunks)
  where
    go :: ForeignPtr Session -> [Chunk] -> IO [Location]
    go :: ForeignPtr Session -> [Chunk] -> IO [Location]
go ForeignPtr Session
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    go ForeignPtr Session
sess (Chunk
chunk : [Chunk]
chunks) = do
        [Location]
this <- ForeignPtr Session -> Chunk -> IO [Location]
iterChunk ForeignPtr Session
sess Chunk
chunk
        [Location]
rest <- forall a. IO a -> IO a
unsafeInterleaveIO (ForeignPtr Session -> [Chunk] -> IO [Location]
go ForeignPtr Session
sess [Chunk]
chunks)
        forall (m :: * -> *) a. Monad m => a -> m a
return ([Location]
this forall a. [a] -> [a] -> [a]
++ [Location]
rest)

    {-
    Here we lazily lookup the location information associated with each address
    as this can be rather costly. This does mean, however, that if the set of
    loaded modules changes between the time that we capture the stack and the
    time we reach here, we may end up with nonsense (mostly likely merely
    unknown symbols). I think this is a reasonable price to pay, however, as
    module loading/unloading is a rather rare event.

    Moreover, we stand to gain a great deal by lazy lookups as the stack frames
    may never even be requested, meaning the only effort wasted is the
    collection of the stack frames themselves.

    The only slightly tricky thing here is to ensure that the ForeignPtr
    stays alive until we reach the end.
    -}
    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
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
        iterFrames Word
n Ptr Addr
frame = do
            Addr
pc <- forall a. Storable a => Ptr a -> IO a
peek Ptr Addr
frame :: IO Addr
            Maybe Location
mframe <- Addr -> IO (Maybe Location)
lookupFrame Addr
pc
            [Location]
rest <- forall a. IO a -> IO a
unsafeInterleaveIO (Word -> Ptr Addr -> IO [Location]
iterFrames (Word
nforall a. Num a => a -> a -> a
-Word
1) forall a. Ptr a
frame')
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Location]
rest (forall a. a -> [a] -> [a]
:[Location]
rest) Maybe Location
mframe
          where
            frame' :: Ptr b
frame' = Ptr Addr
frame forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: Addr)

        lookupFrame :: Addr -> IO (Maybe Location)
        lookupFrame :: Addr -> IO (Maybe Location)
lookupFrame Addr
pc = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr StackTrace
fptr forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
            forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
locationSize forall a b. (a -> b) -> a -> b
$ \Ptr Location
buf -> do
                CInt
ret <- forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Session
sess 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 CInt
ret of
                  CInt
0 -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Location -> IO Location
peekLocation Ptr Location
buf
                  CInt
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | A LibdwSession from the runtime system
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 ())

-- | Get an execution stack.
collectStackTrace :: IO (Maybe StackTrace)
collectStackTrace :: IO (Maybe StackTrace)
collectStackTrace = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. (ForeignPtr Session -> IO a) -> IO (Maybe a)
withSession forall a b. (a -> b) -> a -> b
$ \ForeignPtr Session
sess -> do
    Ptr StackTrace
st <- forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Session
sess Ptr Session -> IO (Ptr StackTrace)
libdw_get_backtrace
    if | Ptr StackTrace
st forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
       | Bool
otherwise     -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr StackTrace -> StackTrace
StackTrace forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FunPtr (Ptr StackTrace -> IO ())
backtrace_free Ptr StackTrace
st

-- | Free the cached debug data.
invalidateDebugCache :: IO ()
invalidateDebugCache :: IO ()
invalidateDebugCache = IO ()
libdw_pool_clear

-- | Render a stacktrace as a string
showStackFrames :: [Location] -> ShowS
showStackFrames :: [Location] -> ShowS
showStackFrames [Location]
frames =
    String -> ShowS
showString String
"Stack trace:\n"
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a b. (a -> b) -> [a] -> [b]
map Location -> ShowS
showFrame [Location]
frames)
  where
    showFrame :: Location -> ShowS
showFrame Location
loc =
      String -> ShowS
showString String
"    " forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> ShowS
showLocation Location
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\n'

-- | Render a 'Location' as a string
showLocation :: Location -> ShowS
showLocation :: Location -> ShowS
showLocation Location
loc =
        String -> ShowS
showString (Location -> String
functionName Location
loc)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id SrcLoc -> ShowS
showSrcLoc (Location -> Maybe SrcLoc
srcLoc Location
loc)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" in "
      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
" ("
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (SrcLoc -> String
sourceFile SrcLoc
sloc)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
":"
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows (SrcLoc -> Int
sourceLine SrcLoc
sloc)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"."
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows (SrcLoc -> Int
sourceColumn SrcLoc
sloc)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")"