From ba14f04dae398c102209e3374bea882ebf823257 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Thu, 26 Nov 2015 12:12:32 +0100
Subject: Libdw: Handle failure to grab session for location lookup

This one slipped through testing.
---
 libraries/base/GHC/ExecutionStack.hs           |  5 +++--
 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
-- 
cgit v1.2.1