[commit: ghc] ghc-8.0: Add -prof stack trace to assert (b54ea29)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/b54ea2949573c8684f32d3cb2b761fe32c557a3f/ghc

>---------------------------------------------------------------

commit b54ea2949573c8684f32d3cb2b761fe32c557a3f
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Mon Jan 11 18:30:29 2016 +0000

    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
    
    (cherry picked from commit 6cb860a9a154847906868ac0be93d750f99dac86)


>---------------------------------------------------------------

b54ea2949573c8684f32d3cb2b761fe32c557a3f
 libraries/base/GHC/Exception.hs    |  3 ++-
 libraries/base/GHC/IO/Exception.hs | 12 +++++++++---
 libraries/base/GHC/Stack/CCS.hsc   |  3 ++-
 3 files changed, 13 insertions(+), 5 deletions(-)

diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs
index 80761ad..6c579f0 100644
--- a/libraries/base/GHC/Exception.hs
+++ b/libraries/base/GHC/Exception.hs
@@ -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
 
diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs
index 933ce94..c7bccb0 100644
--- a/libraries/base/GHC/IO/Exception.hs
+++ b/libraries/base/GHC/IO/Exception.hs
@@ -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 =
diff --git a/libraries/base/GHC/Stack/CCS.hsc b/libraries/base/GHC/Stack/CCS.hsc
index d40d92d..bab9f75 100644
--- a/libraries/base/GHC/Stack/CCS.hsc
+++ b/libraries/base/GHC/Stack/CCS.hsc
@@ -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)