diff options
| -rw-r--r-- | libraries/base/GHC/ExecutionStack.hs | 5 | ||||
| -rw-r--r-- | libraries/base/GHC/ExecutionStack/Internal.hsc | 14 |
2 files changed, 12 insertions, 7 deletions
diff --git a/libraries/base/GHC/ExecutionStack.hs b/libraries/base/GHC/ExecutionStack.hs index 245b996467..11f8c9e50a 100644 --- a/libraries/base/GHC/ExecutionStack.hs +++ b/libraries/base/GHC/ExecutionStack.hs @@ -36,14 +36,15 @@ module GHC.ExecutionStack ( , showStackTrace ) where +import Control.Monad (join) import GHC.ExecutionStack.Internal -- | Get a trace of the current execution stack state. -- -- Returns @Nothing@ if stack trace support isn't available on host machine. 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. showStackTrace :: IO (Maybe String) -showStackTrace = fmap (flip showStackFrames "") `fmap` getStackTrace +showStackTrace = fmap (\st -> showStackFrames st "") `fmap` getStackTrace diff --git a/libraries/base/GHC/ExecutionStack/Internal.hsc b/libraries/base/GHC/ExecutionStack/Internal.hsc index 7a30feaafe..e966e17056 100644 --- a/libraries/base/GHC/ExecutionStack/Internal.hsc +++ b/libraries/base/GHC/ExecutionStack/Internal.hsc @@ -31,6 +31,7 @@ module GHC.ExecutionStack.Internal ( , invalidateDebugCache ) where +import Control.Monad (join) import Data.Word import Foreign.C.Types import Foreign.C.String (peekCString, CString) @@ -66,11 +67,14 @@ newtype StackTrace = StackTrace (ForeignPtr StackTrace) -- | An address type Addr = Ptr () -withSession :: (ForeignPtr Session -> IO a) -> IO a +withSession :: (ForeignPtr Session -> IO a) -> IO (Maybe a) withSession action = do ptr <- libdw_pool_take - fptr <- newForeignPtr libdw_pool_release ptr - action fptr + if | nullPtr == ptr -> return Nothing + | otherwise -> do + fptr <- newForeignPtr libdw_pool_release ptr + ret <- action fptr + return $ Just ret -- | How many stack frames in the given 'StackTrace' stackDepth :: StackTrace -> Int @@ -126,7 +130,7 @@ locationSize :: Int locationSize = (#const sizeof(Location)) -- | List the frames of a stack trace. -stackFrames :: StackTrace -> [Location] +stackFrames :: StackTrace -> Maybe [Location] stackFrames st@(StackTrace fptr) = unsafePerformIO $ withSession $ \sess -> do chunks <- chunksList st go sess (reverse chunks) @@ -197,7 +201,7 @@ foreign import ccall unsafe "&backtraceFree" -- | Get an execution stack. collectStackTrace :: IO (Maybe StackTrace) -collectStackTrace = withSession $ \sess -> do +collectStackTrace = fmap join $ withSession $ \sess -> do st <- withForeignPtr sess libdw_get_backtrace if | st == nullPtr -> return Nothing | otherwise -> Just . StackTrace <$> newForeignPtr backtrace_free st |