Add -prof stack trace to assert
authorSimon Marlow <marlowsd@gmail.com>
Mon, 11 Jan 2016 18:30:29 +0000 (18:30 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Wed, 13 Jan 2016 13:06:07 +0000 (13:06 +0000)
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

libraries/base/GHC/Exception.hs
libraries/base/GHC/IO/Exception.hs
libraries/base/GHC/Stack/CCS.hsc

index 80761ad..6c579f0 100644 (file)
@@ -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
 
index 933ce94..c7bccb0 100644 (file)
@@ -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 =
index d40d92d..bab9f75 100644 (file)
@@ -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)