Make 'error' include the CCS call stack when profiled

Summary:
The idea here is that this gives a more detailed stack trace in two
cases:

1. With `-prof` and `-fprof-auto`
2. In GHCi (see #11047)

Example, with an error inserted in nofib/shootout/binary-trees:

```
$ ./Main 3
Main: z
CallStack (from ImplicitParams):
  error, called at Main.hs:67:29 in main:Main
CallStack (from -prof):
  Main.check' (Main.hs:(67,1)-(68,82))
  Main.check (Main.hs:63:1-21)
  Main.stretch (Main.hs:32:35-57)
  Main.main.c (Main.hs:32:9-57)
  Main.main (Main.hs:(27,1)-(43,42))
  Main.CAF (<entire-module>)
```

This doesn't quite obsolete +RTS -xc, which also attempts to display
more information in the case when the error is in a CAF, but I'm
exploring other solutions to that.

Includes submodule updates.

Test Plan: validate

Reviewers: simonpj, ezyang, gridaphobe, bgamari, hvr, austin

Reviewed By: bgamari

Subscribers: thomie

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

1 files changed, 20 insertions, 13 deletions

diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs
index 20b487cc9c..c31a203f9b 100644
--- a/libraries/base/GHC/Exception.hs
+++ b/libraries/base/GHC/Exception.hs
@@ -38,6 +38,9 @@ import Data.Typeable (Typeable, cast)
 import GHC.Base
 import GHC.Show
 import GHC.Stack.Types
+import GHC.OldList
+import GHC.IO.Unsafe
+import {-# SOURCE #-} GHC.Stack.CCS
 
 {- |
 The @SomeException@ type is the root of the exception type hierarchy.
@@ -180,9 +183,17 @@ errorCallException :: String -> SomeException
 errorCallException s = toException (ErrorCall s)
 
 errorCallWithCallStackException :: String -> CallStack -> SomeException
-errorCallWithCallStackException s stk
-  = toException (ErrorCallWithLocation s (showCallStack (popCallStack stk)))
-
+errorCallWithCallStackException s stk = unsafeDupablePerformIO $ do
+  ccsStack <- currentCallStack
+  let
+    implicitParamCallStack = showCallStackLines (popCallStack stk)
+    ccsCallStack = showCCSStack ccsStack
+    stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack
+  return $ toException (ErrorCallWithLocation s stack)
+
+showCCSStack :: [String] -> [String]
+showCCSStack [] = []
+showCCSStack stk = "CallStack (from -prof):" : map ("  " ++) (reverse stk)
 
 -- | Pretty print 'SrcLoc'
 --
@@ -200,17 +211,13 @@ showSrcLoc SrcLoc {..}
 --
 -- @since 4.9.0.0
 showCallStack :: CallStack -> String
-showCallStack (CallStack stk@(_:_))
-  = unlines ("CallStack:" : map (indent . showCallSite) stk)
-  where
-  -- Data.OldList isn't available yet, so we repeat the definition here
-  unlines [] = []
-  unlines [l] = l
-  unlines (l:ls) = l ++ '\n' : unlines ls
-  indent l = "  " ++ l
-  showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc
-showCallStack _ = error "CallStack cannot be empty!"
+showCallStack = intercalate "\n" . showCallStackLines
 
+showCallStackLines :: CallStack -> [String]
+showCallStackLines (CallStack stk) =
+    "CallStack (from ImplicitParams):" : map (("  " ++) . showCallSite) stk
+  where
+    showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc
 
 -- | Remove the most recent callsite from the 'CallStack'
 --