diff options
| author | Ben Gamari <bgamari.foss@gmail.com> | 2017-07-28 18:25:35 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-07-28 18:25:37 -0400 |
| commit | 84f8e86248d47f619a94c68260876a1258e0a931 (patch) | |
| tree | 3756862bea5f88211423346c0c058dcf196950b8 | |
| parent | d75bba852db208b1d9fcb84dab01598a765d2534 (diff) | |
| download | haskell-84f8e86248d47f619a94c68260876a1258e0a931.tar.gz | |
Ensure that GHC.Stack.callStack doesn't fail
Test Plan: Validate, ensure the `f7` program of `IPLocation` doesn't
crash.
Reviewers: gridaphobe, austin, hvr
Reviewed By: gridaphobe
Subscribers: rwbarton, thomie
GHC Trac Issues: #14028
Differential Revision: https://phabricator.haskell.org/D3795
| -rw-r--r-- | libraries/base/GHC/Stack.hs | 5 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_run/IPLocation.hs | 6 |
2 files changed, 10 insertions, 1 deletions
diff --git a/libraries/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs index f5b175c0bb..1f102c9f9b 100644 --- a/libraries/base/GHC/Stack.hs +++ b/libraries/base/GHC/Stack.hs @@ -85,7 +85,10 @@ popCallStack stk = case stk of -- -- @since 4.9.0.0 callStack :: HasCallStack => CallStack -callStack = popCallStack ?callStack +callStack = + case ?callStack of + EmptyCallStack -> EmptyCallStack + _ -> popCallStack ?callStack {-# INLINE callStack #-} -- | Perform some computation without adding new entries to the 'CallStack'. diff --git a/testsuite/tests/typecheck/should_run/IPLocation.hs b/testsuite/tests/typecheck/should_run/IPLocation.hs index 75575e0d16..964728934e 100644 --- a/testsuite/tests/typecheck/should_run/IPLocation.hs +++ b/testsuite/tests/typecheck/should_run/IPLocation.hs @@ -29,9 +29,15 @@ f6 0 = putStrLn $ prettyCallStack ?loc f6 n = f6 (n-1) -- recursive functions add a SrcLoc for each recursive call +f7 :: IO () +f7 = putStrLn (prettyCallStack $ id (\_ -> callStack) ()) + -- shouldn't crash. See #14043. + +main :: IO () main = do f0 f1 f3 (\ () -> putStrLn $ prettyCallStack ?loc) f4 (\ () -> putStrLn $ prettyCallStack ?loc) f5 (\ () -> putStrLn $ prettyCallStack ?loc3) f6 5 + f7 |