Commit 6cb860a9 authored by Simon Marlow's avatar Simon Marlow
Browse files

Add -prof stack trace to assert

Summary:
So that assertion failures have full call stack information attached
when using `ghc -fexternal-interpreter -prof`.  Here's one I just
collected by inserting a dummy assert in Happy:

```
*** Exception: Assertion failed
CallStack (from ImplicitParams):
  assert, called at ./First.lhs:37:11 in main:First
CallStack (from -prof):
  First.mkFirst (First.lhs:37:11-27)
  First.mkFirst (First.lhs:37:11-93)
  Main.main2.runParserGen.first (Main.lhs:107:48-56)
  Main.main2.runParserGen.first (Main.lhs:107:27-57)
  Main.main2.runParserGen (Main.lhs:(96,9)-(276,9))
  Main.main2.runParserGen (Main.lhs:(90,9)-(276,10))
  Main.main2.runParserGen (Main.lhs:(86,9)-(276,10))
  Main.main2.runParserGen (Main.lhs:(85,9)-(276,10))
  Main.main2 (Main.lhs:74:20-43)
  Main.main2 (Main.lhs:(64,9)-(78,61))
  Main.main (Main.lhs:57:9-18)
```

Test Plan: validate

Reviewers: erikd, hvr, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1765

GHC Trac Issues: #11047
parent 00c8076e
......@@ -28,7 +28,8 @@ module GHC.Exception
, divZeroException, overflowException, ratioZeroDenomException
, errorCallException, errorCallWithCallStackException
-- re-export CallStack and SrcLoc from GHC.Types
, CallStack, getCallStack, prettyCallStack
, CallStack, getCallStack, prettyCallStack, prettyCallStackLines
, showCCSStack
, SrcLoc(..), prettySrcLoc
) where
......
......@@ -51,6 +51,8 @@ import GHC.Show
import GHC.Read
import GHC.Exception
import GHC.IO.Handle.Types
import GHC.OldList ( intercalate )
import {-# SOURCE #-} GHC.Stack.CCS
import Foreign.C.Types
import Data.Typeable ( cast )
......@@ -355,9 +357,13 @@ instance Show IOException where
assertError :: (?callStack :: CallStack) => Bool -> a -> a
assertError predicate v
| predicate = lazy v
| otherwise = throw (AssertionFailed
("Assertion failed\n"
++ prettyCallStack ?callStack))
| otherwise = unsafeDupablePerformIO $ do
ccsStack <- currentCallStack
let
implicitParamCallStack = prettyCallStackLines ?callStack
ccsCallStack = showCCSStack ccsStack
stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack
throwIO (AssertionFailed ("Assertion failed\n" ++ stack))
unsupportedOperation :: IOError
unsupportedOperation =
......
......@@ -116,4 +116,5 @@ whoCreated obj = do
ccsToStrings ccs
renderStack :: [String] -> String
renderStack strs = "Stack trace:" ++ concatMap ("\n "++) (reverse strs)
renderStack strs =
"CallStack (from -prof):" ++ concatMap ("\n "++) (reverse strs)
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