Commit ba14f04d authored by Ben Gamari's avatar Ben Gamari 🐢
Browse files

Libdw: Handle failure to grab session for location lookup

This one slipped through testing.
parent 1712a9ed
...@@ -36,14 +36,15 @@ module GHC.ExecutionStack ( ...@@ -36,14 +36,15 @@ module GHC.ExecutionStack (
, showStackTrace , showStackTrace
) where ) where
import Control.Monad (join)
import GHC.ExecutionStack.Internal import GHC.ExecutionStack.Internal
-- | Get a trace of the current execution stack state. -- | Get a trace of the current execution stack state.
-- --
-- Returns @Nothing@ if stack trace support isn't available on host machine. -- Returns @Nothing@ if stack trace support isn't available on host machine.
getStackTrace :: IO (Maybe [Location]) getStackTrace :: IO (Maybe [Location])
getStackTrace = fmap stackFrames `fmap` collectStackTrace getStackTrace = (join . fmap stackFrames) `fmap` collectStackTrace
-- | Get a string representation of the current execution stack state. -- | Get a string representation of the current execution stack state.
showStackTrace :: IO (Maybe String) showStackTrace :: IO (Maybe String)
showStackTrace = fmap (flip showStackFrames "") `fmap` getStackTrace showStackTrace = fmap (\st -> showStackFrames st "") `fmap` getStackTrace
...@@ -31,6 +31,7 @@ module GHC.ExecutionStack.Internal ( ...@@ -31,6 +31,7 @@ module GHC.ExecutionStack.Internal (
, invalidateDebugCache , invalidateDebugCache
) where ) where
import Control.Monad (join)
import Data.Word import Data.Word
import Foreign.C.Types import Foreign.C.Types
import Foreign.C.String (peekCString, CString) import Foreign.C.String (peekCString, CString)
...@@ -66,11 +67,14 @@ newtype StackTrace = StackTrace (ForeignPtr StackTrace) ...@@ -66,11 +67,14 @@ newtype StackTrace = StackTrace (ForeignPtr StackTrace)
-- | An address -- | An address
type Addr = Ptr () type Addr = Ptr ()
withSession :: (ForeignPtr Session -> IO a) -> IO a withSession :: (ForeignPtr Session -> IO a) -> IO (Maybe a)
withSession action = do withSession action = do
ptr <- libdw_pool_take ptr <- libdw_pool_take
fptr <- newForeignPtr libdw_pool_release ptr if | nullPtr == ptr -> return Nothing
action fptr | otherwise -> do
fptr <- newForeignPtr libdw_pool_release ptr
ret <- action fptr
return $ Just ret
-- | How many stack frames in the given 'StackTrace' -- | How many stack frames in the given 'StackTrace'
stackDepth :: StackTrace -> Int stackDepth :: StackTrace -> Int
...@@ -126,7 +130,7 @@ locationSize :: Int ...@@ -126,7 +130,7 @@ locationSize :: Int
locationSize = (#const sizeof(Location)) locationSize = (#const sizeof(Location))
-- | List the frames of a stack trace. -- | List the frames of a stack trace.
stackFrames :: StackTrace -> [Location] stackFrames :: StackTrace -> Maybe [Location]
stackFrames st@(StackTrace fptr) = unsafePerformIO $ withSession $ \sess -> do stackFrames st@(StackTrace fptr) = unsafePerformIO $ withSession $ \sess -> do
chunks <- chunksList st chunks <- chunksList st
go sess (reverse chunks) go sess (reverse chunks)
...@@ -197,7 +201,7 @@ foreign import ccall unsafe "&backtraceFree" ...@@ -197,7 +201,7 @@ foreign import ccall unsafe "&backtraceFree"
-- | Get an execution stack. -- | Get an execution stack.
collectStackTrace :: IO (Maybe StackTrace) collectStackTrace :: IO (Maybe StackTrace)
collectStackTrace = withSession $ \sess -> do collectStackTrace = fmap join $ withSession $ \sess -> do
st <- withForeignPtr sess libdw_get_backtrace st <- withForeignPtr sess libdw_get_backtrace
if | st == nullPtr -> return Nothing if | st == nullPtr -> return Nothing
| otherwise -> Just . StackTrace <$> newForeignPtr backtrace_free st | otherwise -> Just . StackTrace <$> newForeignPtr backtrace_free st
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment