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

10 files changed, 396 insertions, 171 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'
 --
diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs
index f38c88f009..186f6c65c5 100644
--- a/libraries/base/GHC/IO.hs
+++ b/libraries/base/GHC/IO.hs
@@ -44,6 +44,7 @@ import GHC.Base
 import GHC.ST
 import GHC.Exception
 import GHC.Show
+import GHC.IO.Unsafe
 
 import {-# SOURCE #-} GHC.IO.Exception ( userError, IOError )
 
@@ -101,160 +102,6 @@ unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s
 unsafeSTToIO :: ST s a -> IO a
 unsafeSTToIO (ST m) = IO (unsafeCoerce# m)
 
--- ---------------------------------------------------------------------------
--- Unsafe IO operations
-
-{-|
-This is the \"back door\" into the 'IO' monad, allowing
-'IO' computation to be performed at any time.  For
-this to be safe, the 'IO' computation should be
-free of side effects and independent of its environment.
-
-If the I\/O computation wrapped in 'unsafePerformIO' performs side
-effects, then the relative order in which those side effects take
-place (relative to the main I\/O trunk, or other calls to
-'unsafePerformIO') is indeterminate.  Furthermore, when using
-'unsafePerformIO' to cause side-effects, you should take the following
-precautions to ensure the side effects are performed as many times as
-you expect them to be.  Note that these precautions are necessary for
-GHC, but may not be sufficient, and other compilers may require
-different precautions:
-
-  * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@
-        that calls 'unsafePerformIO'.  If the call is inlined,
-        the I\/O may be performed more than once.
-
-  * Use the compiler flag @-fno-cse@ to prevent common sub-expression
-        elimination being performed on the module, which might combine
-        two side effects that were meant to be separate.  A good example
-        is using multiple global variables (like @test@ in the example below).
-
-  * Make sure that the either you switch off let-floating (@-fno-full-laziness@), or that the
-        call to 'unsafePerformIO' cannot float outside a lambda.  For example,
-        if you say:
-        @
-           f x = unsafePerformIO (newIORef [])
-        @
-        you may get only one reference cell shared between all calls to @f@.
-        Better would be
-        @
-           f x = unsafePerformIO (newIORef [x])
-        @
-        because now it can't float outside the lambda.
-
-It is less well known that
-'unsafePerformIO' is not type safe.  For example:
-
->     test :: IORef [a]
->     test = unsafePerformIO $ newIORef []
->
->     main = do
->             writeIORef test [42]
->             bang <- readIORef test
->             print (bang :: [Char])
-
-This program will core dump.  This problem with polymorphic references
-is well known in the ML community, and does not arise with normal
-monadic use of references.  There is no easy way to make it impossible
-once you use 'unsafePerformIO'.  Indeed, it is
-possible to write @coerce :: a -> b@ with the
-help of 'unsafePerformIO'.  So be careful!
--}
-unsafePerformIO :: IO a -> a
-unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m)
-
-{-|
-This version of 'unsafePerformIO' is more efficient
-because it omits the check that the IO is only being performed by a
-single thread.  Hence, when you use 'unsafeDupablePerformIO',
-there is a possibility that the IO action may be performed multiple
-times (on a multiprocessor), and you should therefore ensure that
-it gives the same results each time. It may even happen that one
-of the duplicated IO actions is only run partially, and then interrupted
-in the middle without an exception being raised. Therefore, functions
-like 'bracket' cannot be used safely within 'unsafeDupablePerformIO'.
-
-@since 4.4.0.0
--}
-unsafeDupablePerformIO  :: IO a -> a
-unsafeDupablePerformIO (IO m) = case runRW# m of (# _, a #) -> a
-
--- Note [unsafeDupablePerformIO is NOINLINE]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Why do we NOINLINE unsafeDupablePerformIO?  See the comment with
--- GHC.ST.runST.  Essentially the issue is that the IO computation
--- inside unsafePerformIO must be atomic: it must either all run, or
--- not at all.  If we let the compiler see the application of the IO
--- to realWorld#, it might float out part of the IO.
-
--- Note [unsafeDupablePerformIO has a lazy RHS]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Why is there a call to 'lazy' in unsafeDupablePerformIO?
--- If we don't have it, the demand analyser discovers the following strictness
--- for unsafeDupablePerformIO:  C(U(AV))
--- But then consider
---      unsafeDupablePerformIO (\s -> let r = f x in
---                             case writeIORef v r s of (# s1, _ #) ->
---                             (# s1, r #) )
--- The strictness analyser will find that the binding for r is strict,
--- (because of uPIO's strictness sig), and so it'll evaluate it before
--- doing the writeIORef.  This actually makes libraries/base/tests/memo002
--- get a deadlock, where we specifically wanted to write a lazy thunk
--- into the ref cell.
---
--- Solution: don't expose the strictness of unsafeDupablePerformIO,
---           by hiding it with 'lazy'
--- But see discussion in Trac #9390 (comment:33)
-
-{-|
-'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily.
-When passed a value of type @IO a@, the 'IO' will only be performed
-when the value of the @a@ is demanded.  This is used to implement lazy
-file reading, see 'System.IO.hGetContents'.
--}
-{-# INLINE unsafeInterleaveIO #-}
-unsafeInterleaveIO :: IO a -> IO a
-unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m)
-
--- We used to believe that INLINE on unsafeInterleaveIO was safe,
--- because the state from this IO thread is passed explicitly to the
--- interleaved IO, so it cannot be floated out and shared.
---
--- HOWEVER, if the compiler figures out that r is used strictly here,
--- then it will eliminate the thunk and the side effects in m will no
--- longer be shared in the way the programmer was probably expecting,
--- but can be performed many times.  In #5943, this broke our
--- definition of fixIO, which contains
---
---    ans <- unsafeInterleaveIO (takeMVar m)
---
--- after inlining, we lose the sharing of the takeMVar, so the second
--- time 'ans' was demanded we got a deadlock.  We could fix this with
--- a readMVar, but it seems wrong for unsafeInterleaveIO to sometimes
--- share and sometimes not (plus it probably breaks the noDuplicate).
--- So now, we do not inline unsafeDupableInterleaveIO.
-
-{-# NOINLINE unsafeDupableInterleaveIO #-}
-unsafeDupableInterleaveIO :: IO a -> IO a
-unsafeDupableInterleaveIO (IO m)
-  = IO ( \ s -> let
-                   r = case m s of (# _, res #) -> res
-                in
-                (# s, r #))
-
-{-|
-Ensures that the suspensions under evaluation by the current thread
-are unique; that is, the current thread is not evaluating anything
-that is also under evaluation by another thread that has also executed
-'noDuplicate'.
-
-This operation is used in the definition of 'unsafePerformIO' to
-prevent the IO action from being executed multiple times, which is usually
-undesirable.
--}
-noDuplicate :: IO ()
-noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #)
-
 -- -----------------------------------------------------------------------------
 -- | File and directory names are values of type 'String', whose precise
 -- meaning is operating system dependent. Files can be opened, yielding a
diff --git a/libraries/base/GHC/IO/Unsafe.hs b/libraries/base/GHC/IO/Unsafe.hs
new file mode 100644
index 0000000000..5bb982421b
--- /dev/null
+++ b/libraries/base/GHC/IO/Unsafe.hs
@@ -0,0 +1,180 @@
+{-# LANGUAGE Unsafe #-}
+{-# LANGUAGE NoImplicitPrelude
+           , MagicHash
+           , UnboxedTuples
+  #-}
+{-# OPTIONS_HADDOCK hide #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.IO.Unsafe
+-- Copyright   :  (c) The University of Glasgow 1994-2002
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Unsafe IO operations
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Unsafe (
+    unsafePerformIO, unsafeInterleaveIO,
+    unsafeDupablePerformIO, unsafeDupableInterleaveIO,
+    noDuplicate,
+  ) where
+
+import GHC.Base
+
+
+{-|
+This is the \"back door\" into the 'IO' monad, allowing
+'IO' computation to be performed at any time.  For
+this to be safe, the 'IO' computation should be
+free of side effects and independent of its environment.
+
+If the I\/O computation wrapped in 'unsafePerformIO' performs side
+effects, then the relative order in which those side effects take
+place (relative to the main I\/O trunk, or other calls to
+'unsafePerformIO') is indeterminate.  Furthermore, when using
+'unsafePerformIO' to cause side-effects, you should take the following
+precautions to ensure the side effects are performed as many times as
+you expect them to be.  Note that these precautions are necessary for
+GHC, but may not be sufficient, and other compilers may require
+different precautions:
+
+  * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@
+        that calls 'unsafePerformIO'.  If the call is inlined,
+        the I\/O may be performed more than once.
+
+  * Use the compiler flag @-fno-cse@ to prevent common sub-expression
+        elimination being performed on the module, which might combine
+        two side effects that were meant to be separate.  A good example
+        is using multiple global variables (like @test@ in the example below).
+
+  * Make sure that the either you switch off let-floating (@-fno-full-laziness@), or that the
+        call to 'unsafePerformIO' cannot float outside a lambda.  For example,
+        if you say:
+        @
+           f x = unsafePerformIO (newIORef [])
+        @
+        you may get only one reference cell shared between all calls to @f@.
+        Better would be
+        @
+           f x = unsafePerformIO (newIORef [x])
+        @
+        because now it can't float outside the lambda.
+
+It is less well known that
+'unsafePerformIO' is not type safe.  For example:
+
+>     test :: IORef [a]
+>     test = unsafePerformIO $ newIORef []
+>
+>     main = do
+>             writeIORef test [42]
+>             bang <- readIORef test
+>             print (bang :: [Char])
+
+This program will core dump.  This problem with polymorphic references
+is well known in the ML community, and does not arise with normal
+monadic use of references.  There is no easy way to make it impossible
+once you use 'unsafePerformIO'.  Indeed, it is
+possible to write @coerce :: a -> b@ with the
+help of 'unsafePerformIO'.  So be careful!
+-}
+unsafePerformIO :: IO a -> a
+unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m)
+
+{-|
+This version of 'unsafePerformIO' is more efficient
+because it omits the check that the IO is only being performed by a
+single thread.  Hence, when you use 'unsafeDupablePerformIO',
+there is a possibility that the IO action may be performed multiple
+times (on a multiprocessor), and you should therefore ensure that
+it gives the same results each time. It may even happen that one
+of the duplicated IO actions is only run partially, and then interrupted
+in the middle without an exception being raised. Therefore, functions
+like 'bracket' cannot be used safely within 'unsafeDupablePerformIO'.
+
+@since 4.4.0.0
+-}
+unsafeDupablePerformIO  :: IO a -> a
+unsafeDupablePerformIO (IO m) = case runRW# m of (# _, a #) -> a
+
+-- Note [unsafeDupablePerformIO is NOINLINE]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Why do we NOINLINE unsafeDupablePerformIO?  See the comment with
+-- GHC.ST.runST.  Essentially the issue is that the IO computation
+-- inside unsafePerformIO must be atomic: it must either all run, or
+-- not at all.  If we let the compiler see the application of the IO
+-- to realWorld#, it might float out part of the IO.
+
+-- Note [unsafeDupablePerformIO has a lazy RHS]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Why is there a call to 'lazy' in unsafeDupablePerformIO?
+-- If we don't have it, the demand analyser discovers the following strictness
+-- for unsafeDupablePerformIO:  C(U(AV))
+-- But then consider
+--      unsafeDupablePerformIO (\s -> let r = f x in
+--                             case writeIORef v r s of (# s1, _ #) ->
+--                             (# s1, r #) )
+-- The strictness analyser will find that the binding for r is strict,
+-- (because of uPIO's strictness sig), and so it'll evaluate it before
+-- doing the writeIORef.  This actually makes libraries/base/tests/memo002
+-- get a deadlock, where we specifically wanted to write a lazy thunk
+-- into the ref cell.
+--
+-- Solution: don't expose the strictness of unsafeDupablePerformIO,
+--           by hiding it with 'lazy'
+-- But see discussion in Trac #9390 (comment:33)
+
+{-|
+'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily.
+When passed a value of type @IO a@, the 'IO' will only be performed
+when the value of the @a@ is demanded.  This is used to implement lazy
+file reading, see 'System.IO.hGetContents'.
+-}
+{-# INLINE unsafeInterleaveIO #-}
+unsafeInterleaveIO :: IO a -> IO a
+unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m)
+
+-- We used to believe that INLINE on unsafeInterleaveIO was safe,
+-- because the state from this IO thread is passed explicitly to the
+-- interleaved IO, so it cannot be floated out and shared.
+--
+-- HOWEVER, if the compiler figures out that r is used strictly here,
+-- then it will eliminate the thunk and the side effects in m will no
+-- longer be shared in the way the programmer was probably expecting,
+-- but can be performed many times.  In #5943, this broke our
+-- definition of fixIO, which contains
+--
+--    ans <- unsafeInterleaveIO (takeMVar m)
+--
+-- after inlining, we lose the sharing of the takeMVar, so the second
+-- time 'ans' was demanded we got a deadlock.  We could fix this with
+-- a readMVar, but it seems wrong for unsafeInterleaveIO to sometimes
+-- share and sometimes not (plus it probably breaks the noDuplicate).
+-- So now, we do not inline unsafeDupableInterleaveIO.
+
+{-# NOINLINE unsafeDupableInterleaveIO #-}
+unsafeDupableInterleaveIO :: IO a -> IO a
+unsafeDupableInterleaveIO (IO m)
+  = IO ( \ s -> let
+                   r = case m s of (# _, res #) -> res
+                in
+                (# s, r #))
+
+{-|
+Ensures that the suspensions under evaluation by the current thread
+are unique; that is, the current thread is not evaluating anything
+that is also under evaluation by another thread that has also executed
+'noDuplicate'.
+
+This operation is used in the definition of 'unsafePerformIO' to
+prevent the IO action from being executed multiple times, which is usually
+undesirable.
+-}
+noDuplicate :: IO ()
+noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #)
diff --git a/libraries/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs
new file mode 100644
index 0000000000..d1dd596ca6
--- /dev/null
+++ b/libraries/base/GHC/Stack.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE Trustworthy #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.Stack
+-- Copyright   :  (c) The University of Glasgow 2011
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Access to GHC's call-stack simulation
+--
+-- @since 4.5.0.0
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
+module GHC.Stack (
+    -- * Call stacks
+    currentCallStack,
+    whoCreated,
+    errorWithStackTrace,
+
+    -- * Implicit parameter call stacks
+    SrcLoc(..), CallStack(..),
+
+    -- * Internals
+    CostCentreStack,
+    CostCentre,
+    getCurrentCCS,
+    getCCSOf,
+    ccsCC,
+    ccsParent,
+    ccLabel,
+    ccModule,
+    ccSrcSpan,
+    ccsToStrings,
+    renderStack
+  ) where
+
+import GHC.Stack.CCS
+import GHC.IO
+import GHC.Base
+import GHC.List
+import GHC.Exception
+
+-- | Like the function 'error', but appends a stack trace to the error
+-- message if one is available.
+--
+-- @since 4.7.0.0
+{-# DEPRECATED errorWithStackTrace "'error' appends the call stack now" #-}
+  -- DEPRECATED in 8.0.1
+errorWithStackTrace :: String -> a
+errorWithStackTrace x = unsafeDupablePerformIO $ do
+   stack <- ccsToStrings =<< getCurrentCCS x
+   if null stack
+      then throwIO (ErrorCall x)
+      else throwIO (ErrorCallWithLocation x (renderStack stack))
diff --git a/libraries/base/GHC/Stack.hsc b/libraries/base/GHC/Stack.hsc
index 6ef1fa5d25..c544721e63 100644
--- a/libraries/base/GHC/Stack.hsc
+++ b/libraries/base/GHC/Stack.hsc
@@ -47,7 +47,6 @@ import GHC.Base
 import GHC.Ptr
 import GHC.Foreign as GHC
 import GHC.IO.Encoding
-import GHC.Exception
 import GHC.List ( concatMap, null, reverse )
 
 #define PROFILING
diff --git a/libraries/base/GHC/Stack/CCS.hs-boot b/libraries/base/GHC/Stack/CCS.hs-boot
new file mode 100644
index 0000000000..1ac7876921
--- /dev/null
+++ b/libraries/base/GHC/Stack/CCS.hs-boot
@@ -0,0 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module GHC.Stack.CCS where
+
+{- Cuts the following loop:
+
+   GHC.Exception.errorCallWithCallStackException requires
+   GHC.Stack.CCS.currentCallStack, which requires
+   Foreign.C (for peeking CostCentres)
+   GHC.Foreign, GHC.IO.Encoding (for decoding UTF-8 strings)
+   .. lots of stuff ...
+   GHC.Exception
+-}
+
+import GHC.Base
+
+currentCallStack :: IO [String]
diff --git a/libraries/base/GHC/Stack/CCS.hsc b/libraries/base/GHC/Stack/CCS.hsc
new file mode 100644
index 0000000000..6d62a1e235
--- /dev/null
+++ b/libraries/base/GHC/Stack/CCS.hsc
@@ -0,0 +1,116 @@
+{-# LANGUAGE Trustworthy #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.Stack.CCS
+-- Copyright   :  (c) The University of Glasgow 2011
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Access to GHC's call-stack simulation
+--
+-- @since 4.5.0.0
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
+module GHC.Stack.CCS (
+    -- * Call stacks
+    currentCallStack,
+    whoCreated,
+
+    -- * Internals
+    CostCentreStack,
+    CostCentre,
+    getCurrentCCS,
+    getCCSOf,
+    ccsCC,
+    ccsParent,
+    ccLabel,
+    ccModule,
+    ccSrcSpan,
+    ccsToStrings,
+    renderStack
+  ) where
+
+import Foreign
+import Foreign.C
+
+import GHC.Base
+import GHC.Ptr
+import GHC.Foreign as GHC
+import GHC.IO.Encoding
+import GHC.List ( concatMap, reverse )
+
+#define PROFILING
+#include "Rts.h"
+
+data CostCentreStack
+data CostCentre
+
+getCurrentCCS :: dummy -> IO (Ptr CostCentreStack)
+getCurrentCCS dummy = IO $ \s ->
+   case getCurrentCCS## dummy s of
+     (## s', addr ##) -> (## s', Ptr addr ##)
+
+getCCSOf :: a -> IO (Ptr CostCentreStack)
+getCCSOf obj = IO $ \s ->
+   case getCCSOf## obj s of
+     (## s', addr ##) -> (## s', Ptr addr ##)
+
+ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)
+ccsCC p = (# peek CostCentreStack, cc) p
+
+ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
+ccsParent p = (# peek CostCentreStack, prevStack) p
+
+ccLabel :: Ptr CostCentre -> IO CString
+ccLabel p = (# peek CostCentre, label) p
+
+ccModule :: Ptr CostCentre -> IO CString
+ccModule p = (# peek CostCentre, module) p
+
+ccSrcSpan :: Ptr CostCentre -> IO CString
+ccSrcSpan p = (# peek CostCentre, srcloc) p
+
+-- | returns a '[String]' representing the current call stack.  This
+-- can be useful for debugging.
+--
+-- The implementation uses the call-stack simulation maintined by the
+-- profiler, so it only works if the program was compiled with @-prof@
+-- and contains suitable SCC annotations (e.g. by using @-fprof-auto@).
+-- Otherwise, the list returned is likely to be empty or
+-- uninformative.
+--
+-- @since 4.5.0.0
+
+currentCallStack :: IO [String]
+currentCallStack = ccsToStrings =<< getCurrentCCS ()
+
+ccsToStrings :: Ptr CostCentreStack -> IO [String]
+ccsToStrings ccs0 = go ccs0 []
+  where
+    go ccs acc
+     | ccs == nullPtr = return acc
+     | otherwise = do
+        cc  <- ccsCC ccs
+        lbl <- GHC.peekCString utf8 =<< ccLabel cc
+        mdl <- GHC.peekCString utf8 =<< ccModule cc
+        loc <- GHC.peekCString utf8 =<< ccSrcSpan cc
+        parent <- ccsParent ccs
+        if (mdl == "MAIN" && lbl == "MAIN")
+           then return acc
+           else go parent ((mdl ++ '.':lbl ++ ' ':'(':loc ++ ")") : acc)
+
+-- | Get the stack trace attached to an object.
+--
+-- @since 4.5.0.0
+whoCreated :: a -> IO [String]
+whoCreated obj = do
+  ccs <- getCCSOf obj
+  ccsToStrings ccs
+
+renderStack :: [String] -> String
+renderStack strs = "Stack trace:" ++ concatMap ("\n  "++) (reverse strs)
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index e94d38949a..7c89be4cfa 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -238,6 +238,7 @@ Library
         GHC.IO.Handle.Text
         GHC.IO.Handle.Types
         GHC.IO.IOMode
+        GHC.IO.Unsafe
         GHC.IOArray
         GHC.IORef
         GHC.Int
@@ -259,6 +260,7 @@ Library
         GHC.Show
         GHC.Stable
         GHC.Stack
+        GHC.Stack.CCS
         GHC.Stack.Types
         GHC.Stats
         GHC.Storable
diff --git a/libraries/base/tests/assert.stderr b/libraries/base/tests/assert.stderr
index 7183f1e763..2f809bd466 100644
--- a/libraries/base/tests/assert.stderr
+++ b/libraries/base/tests/assert.stderr
@@ -1,4 +1,3 @@
 assert: Assertion failed
-CallStack:
+CallStack (from ImplicitParams):
   assert, called at assert.hs:9:11 in main:Main
-
diff --git a/libraries/base/tests/readFloat.stderr b/libraries/base/tests/readFloat.stderr
index 99049a35b7..a3a84648f0 100644
--- a/libraries/base/tests/readFloat.stderr
+++ b/libraries/base/tests/readFloat.stderr
@@ -1,3 +1,3 @@
 readFloat: Prelude.read: no parse
-CallStack:
+CallStack (from ImplicitParams):
   error, called at libraries/base/Text/Read.hs:90:17 in base:Text.Read