Add backtrace capturing and wrap SomeException with SomeExceptionWithLocation

Replace raise# and raiseIO# with throw and throwIO to append backtraces.
And add tests.

The structure is now close to the proposal.

Add pretty printing of backtraces.

-------------------------
Metric Decrease:
    T19695
    T9630
Metric Increase:
    MultiComponentModules
    MultiComponentModulesRecomp
    T13035
    T9872d
-------------------------

67 files changed, 991 insertions, 93 deletions

diff --git a/compiler/GHC/Prelude.hs b/compiler/GHC/Prelude.hs
index 46c5d3ee32..11d83b12c2 100644
--- a/compiler/GHC/Prelude.hs
+++ b/compiler/GHC/Prelude.hs
@@ -46,7 +46,7 @@ NoImplicitPrelude. There are two motivations for this:
 import Prelude as X hiding ((<>))
 import Data.Foldable as X (foldl')
 #if __GLASGOW_HASKELL__ < 903
-import Control.Exception ( Exception, SomeException(..) )
+import Control.Exception ( SomeException(..) )
 #else
 import Control.Exception ( SomeExceptionWithLocation(..) )
 #endif
@@ -104,8 +104,8 @@ shiftR = Bits.unsafeShiftR
 type SomeExceptionWithLocation = SomeException
 
 {-# COMPLETE SomeExceptionWithLocation #-}
-pattern SomeExceptionWithLocation :: forall. forall a. Exception a => a -> () -> SomeException
-pattern SomeExceptionWithLocation e unit <- (\x -> ((), x) -> (unit, SomeException e))
+pattern SomeExceptionWithLocation :: forall. SomeException -> () -> SomeException
+pattern SomeExceptionWithLocation e unit <- (\x -> ((), x) -> (unit, e))
   where
-    SomeExceptionWithLocation e _ = SomeException e
+    SomeExceptionWithLocation (SomeException e) _ = SomeException e
 #endif
diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs
index d697b92af7..7a219c9aad 100644
--- a/compiler/GHC/SysTools/Process.hs
+++ b/compiler/GHC/SysTools/Process.hs
@@ -281,7 +281,7 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = do
             inner hProcess
         case r of
           -- onException
-          Left (SomeExceptionWithLocation e _) -> do
+          Left (SomeExceptionWithLocation (SomeException e) _) -> do
             terminateProcess hProcess
             cleanup_handles
             throw e
diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs
index 673ee55d77..ab8bc837f7 100644
--- a/compiler/GHC/Utils/Panic.hs
+++ b/compiler/GHC/Utils/Panic.hs
@@ -110,7 +110,8 @@ data GhcException
   | PprProgramError String SDoc
 
 instance Exception GhcException where
-  fromException (SomeExceptionWithLocation e _)
+  -- TODO: Print stack traces here
+  fromException (SomeExceptionWithLocation (SomeException e) _)
     | Just ge <- cast e = Just ge
     | Just pge <- cast e = Just $
         case pge of
diff --git a/libraries/Cabal b/libraries/Cabal
-Subproject c5af55a047e26bfe2b7377194771b87bbe3f30f
+Subproject 7ff3c81d300fdb1c78d69ad970824f6d166d83a
diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs
index adbc2f14d0..c20a6ad457 100644
--- a/libraries/base/Control/Exception.hs
+++ b/libraries/base/Control/Exception.hs
@@ -35,6 +35,7 @@ module Control.Exception (
 
         -- * The Exception type
         SomeExceptionWithLocation(..),
+        SomeException(..),
         Exception(..),          -- class
         IOException,            -- instance Eq, Ord, Show, Typeable, Exception
         ArithException(..),     -- instance Eq, Ord, Show, Typeable, Exception
diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs
index 31bf113f7d..a90815d28f 100644
--- a/libraries/base/Control/Exception/Base.hs
+++ b/libraries/base/Control/Exception/Base.hs
@@ -20,6 +20,7 @@ module Control.Exception.Base (
 
         -- * The Exception type
         SomeExceptionWithLocation(..),
+        SomeException(..),
         Exception(..),
         IOException,
         ArithException(..),
diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs
index bf1527076c..229415bce5 100644
--- a/libraries/base/GHC/Base.hs
+++ b/libraries/base/GHC/Base.hs
@@ -120,7 +120,7 @@ import GHC.Prim.Ext
 import GHC.Prim.PtrEq
 import GHC.Err
 import GHC.Maybe
-import {-# SOURCE #-} GHC.IO (mkUserError, mplusIO)
+import {-# SOURCE #-} GHC.IO (mplusIO, throwIOUserError)
 
 import GHC.Tuple (Solo (..))     -- Note [Depend on GHC.Tuple]
 import GHC.Num.Integer ()        -- Note [Depend on GHC.Num.Integer]
@@ -1601,7 +1601,7 @@ thenIO (IO m) k = IO (\ s -> case m s of (# new_s, _ #) -> unIO k new_s)
 -- behavior, which can expose useful simplifications. See
 -- #16588.
 failIO :: String -> IO a
-failIO s = IO (raiseIO# (mkUserError s))
+failIO = throwIOUserError
 
 unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
 unIO (IO a) = a
diff --git a/libraries/base/GHC/Base.hs-boot b/libraries/base/GHC/Base.hs-boot
index 64e6365525..8b8a8d4338 100644
--- a/libraries/base/GHC/Base.hs-boot
+++ b/libraries/base/GHC/Base.hs-boot
@@ -1,9 +1,11 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module GHC.Base (Maybe, Semigroup, Monoid) where
+module GHC.Base (Maybe, Semigroup, Monoid, String) where
 
 import GHC.Maybe (Maybe)
-import GHC.Types ()
+import GHC.Types (Char)
 
 class Semigroup a
 class Monoid a
+
+type String = [Char]
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index d256b64129..109f0f1d3b 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -906,7 +906,7 @@ uncaughtExceptionHandler :: IORef (SomeExceptionWithLocation -> IO ())
 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
    where
       defaultHandler :: SomeExceptionWithLocation -> IO ()
-      defaultHandler se@(SomeExceptionWithLocation ex _) = do
+      defaultHandler se@(SomeExceptionWithLocation (SomeException ex) _) = do
          (hFlush stdout) `catchAny` (\ _ -> return ())
          let msg = case cast ex of
                Just Deadlock -> "no threads to run:  infinite loop or deadlock?"
diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs
index c359dcbdf7..1ba1941ad6 100644
--- a/libraries/base/GHC/Exception.hs
+++ b/libraries/base/GHC/Exception.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE NoImplicitPrelude
            , ExistentialQuantification
            , MagicHash
+           , UnboxedTuples
            , RecordWildCards
            , PatternSynonyms
   #-}
@@ -29,28 +30,90 @@ module GHC.Exception
        , errorCallException
        , errorCallWithCallStackException
          -- re-export CallStack and SrcLoc from GHC.Types
-       , CallStack, fromCallSiteList, getCallStack, prettyCallStack
+       , CallStack, fromCallSiteList, getCallStack, pprBacktraces, prettyCallStack
        , prettyCallStackLines, showCCSStack
        , SrcLoc(..), prettySrcLoc
+       , throwWithCallStack
+       , throwWithIPEStack
+       , throwWithCostCenterStack
+       , throwWithExecutionStack
        ) where
 
 import GHC.Base
-import GHC.Show
-import GHC.Stack.Types
+import GHC.Exception.Backtrace
+import GHC.Exception.Type
+import {-# SOURCE #-} GHC.ExecutionStack.Internal
+import GHC.IO.Unsafe
 import GHC.OldList
 import GHC.Prim
-import GHC.IO.Unsafe
+import GHC.Show
 import {-# SOURCE #-} GHC.Stack.CCS
-import GHC.Exception.Type
+import GHC.Stack.CloneStack.Types (pprStackEntry)
+import GHC.Stack.Types
 
--- | Throw an exception.  Exceptions may be thrown from purely
+-- | Throw an exception. Exceptions may be thrown from purely
 -- functional code, but may only be caught within the 'IO' monad.
+-- 'Backtrace' backtraces are collected according to the configured
+-- 'BacktraceMechanism's.
 --
 -- WARNING: You may want to use 'throwIO' instead so that your pure code
 -- stays exception-free.
-throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
+throw :: HasCallStack => forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
+         Exception e => e -> a
+throw e =
+  runRW#
+    ( \s0 ->
+        let e'@(SomeExceptionWithLocation _ bts) = toException e
+         in if null bts
+              then case unIO collectBacktraces s0 of
+                (# _, bts' #) ->
+                  let e'' = foldr addBacktrace e' bts'
+                   in raise# e''
+              else raise# e'
+    )
+
+-- | Throw an exception with a backtrace gathered by the 'HasCallStackBacktraceMech' mechanism.
+-- If the exception already has backtraces, the new one is added.
+throwWithCallStack :: HasCallStack => forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
          Exception e => e -> a
-throw e = raise# (toException e)
+throwWithCallStack e =
+-- throwWithCallStack cannot call throwWithBacktraceMechanism because that would introduce
+-- unnecessary HasCallStack constraints (that would decrease performance).
+   runRW# (\s0 ->
+    case unIO collectHasCallStackBacktrace s0 of
+      (# _, maybeBt #) ->
+        let e' = case maybeBt of
+                  Just bt -> addBacktrace bt (toException e)
+                  Nothing -> toException e
+        in raise# e')
+
+throwWithBacktraceMechanism :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
+         Exception e => IO (Maybe Backtrace) -> e -> a
+throwWithBacktraceMechanism mech e = runRW# (\s0 ->
+    case unIO mech s0 of
+      (# _, maybeBt #) ->
+        let e' = case maybeBt of
+                  Just bt -> addBacktrace bt (toException e)
+                  Nothing -> toException e
+        in raise# e')
+
+-- | Throw an exception with a 'Backtrace' gathered by the 'IPEBacktraceMech' mechanism.
+-- If the exception already has backtraces, the new one is added.
+throwWithIPEStack :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
+         Exception e => e -> a
+throwWithIPEStack = throwWithBacktraceMechanism collectIPEBacktrace
+
+-- | Throw an exception with a 'Backtrace' gathered by the 'CostCenterBacktraceMech' mechanism.
+-- If the exception already has backtraces, the new one is added.
+throwWithCostCenterStack :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
+         Exception e => e -> a
+throwWithCostCenterStack = throwWithBacktraceMechanism collectCostCenterBacktrace
+
+-- | Throw an exception with a 'Backtrace' gathered by the 'ExecutionStackBacktraceMech' mechanism.
+-- If the exception already has backtraces, the new one is added.
+throwWithExecutionStack :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
+         Exception e => e -> a
+throwWithExecutionStack = throwWithBacktraceMechanism collectExecutionStackBacktrace
 
 -- | This is thrown when the user calls 'error'. The first @String@ is the
 -- argument given to 'error', second @String@ is the location.
@@ -118,3 +181,33 @@ prettyCallStackLines cs = case getCallStack cs of
        : map (("  " ++) . prettyCallSite) stk
   where
     prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc
+
+-- | Pretty print a list of 'Backtrace's
+-- This function should be used to output the backtraces to a terminal.
+-- The format is subject to change. The caller should not depend on it.
+pprBacktraces :: SomeExceptionWithLocation -> String
+pprBacktraces (SomeExceptionWithLocation _ bts) = vcat $ fmap pprBacktrace bts
+
+pprBacktrace :: Backtrace -> String
+pprBacktrace (IPEBacktrace entries) = "Info Table Provenance Entries (IPE) backtrace" ++ ":" $+$ nest 1 (vcat $ map pprStackEntry entries)
+pprBacktrace (HasCallStackBacktrace callStack) = "HasCallStack backtrace" ++ ":" $+$ nest 1 (prettyCallStack callStack)
+pprBacktrace (ExecutionBacktrace locations) = "Debug symbol (DWARF) backtrace" ++ ":" $+$ nest 1 (showStackFrames locations "")
+pprBacktrace (CostCenterBacktrace ptr) = "Cost Centre backtrace" ++ ":" $+$ nest 1 ((renderCCS.unsafePerformIO.ccsToStrings) ptr)
+  where
+    renderCCS :: [String] -> String
+    renderCCS strs = concatMap (\s -> s ++ "\n") (reverse strs)
+
+vcat :: [String] -> String
+vcat = trimFinalNewLines . unlines
+
+nest:: Int -> String -> String
+nest c s = trimFinalNewLines . unlines $ map (spaces ++) (lines s)
+  where
+    spaces :: String
+    spaces = replicate c ' '
+
+trimFinalNewLines :: String -> String
+trimFinalNewLines = reverse . dropWhile ('\n' ==) . reverse
+
+($+$) :: String -> String -> String
+($+$) a b = trimFinalNewLines $ unlines [a,b]
diff --git a/libraries/base/GHC/Exception.hs-boot b/libraries/base/GHC/Exception.hs-boot
index e26566f277..1efd079627 100644
--- a/libraries/base/GHC/Exception.hs-boot
+++ b/libraries/base/GHC/Exception.hs-boot
@@ -1,5 +1,8 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ExistentialQuantification#-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeInType #-}
 
 {-
 This SOURCE-imported hs-boot module cuts a big dependency loop:
@@ -28,11 +31,14 @@ module GHC.Exception
   ( module GHC.Exception.Type
   , errorCallException
   , errorCallWithCallStackException
+  , throw
   ) where
 
 import {-# SOURCE #-} GHC.Exception.Type
-import GHC.Types ( Char )
-import GHC.Stack.Types ( CallStack )
+import GHC.Types ( Char, RuntimeRep, TYPE )
+import GHC.Stack.Types ( CallStack, HasCallStack )
 
 errorCallException :: [Char] -> SomeExceptionWithLocation
 errorCallWithCallStackException :: [Char] -> CallStack -> SomeExceptionWithLocation
+
+throw :: HasCallStack => forall (r :: RuntimeRep). forall (a :: TYPE r). forall e. Exception e => e -> a
diff --git a/libraries/base/GHC/Exception/Backtrace.hs b/libraries/base/GHC/Exception/Backtrace.hs
new file mode 100644
index 0000000000..3eb57a6c53
--- /dev/null
+++ b/libraries/base/GHC/Exception/Backtrace.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_HADDOCK not-home #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.Exception.Backtrace
+-- Copyright   :  (c) The GHC Team, 2020-2021
+-- Authors     :  Ben Gamari, David Eichmann, Sven Tennie
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC extensions)
+--
+-- Collect Exception backtraces with several mechanisms.
+-----------------------------------------------------------------------------
+
+module GHC.Exception.Backtrace
+  ( Backtrace (..),
+    BacktraceMechanism (..),
+    setDefaultBacktraceMechanisms,
+    getDefaultBacktraceMechanisms,
+    showBacktraces,
+    collectBacktraces,
+    collectCostCenterBacktrace,
+    collectExecutionStackBacktrace,
+    collectIPEBacktrace,
+    collectHasCallStackBacktrace
+  )
+where
+
+import qualified Data.OldList as List
+import Data.Maybe
+import GHC.Base
+import {-# SOURCE #-} GHC.ExecutionStack (Location, getStackTrace)
+import {-# SOURCE #-} GHC.ExecutionStack.Internal (showStackFrames)
+import GHC.IO.Unsafe
+import {-# SOURCE #-} GHC.IORef
+import GHC.Ptr
+import GHC.Show
+import {-# SOURCE #-} GHC.Stack
+import {-# SOURCE #-} GHC.Stack.CCS
+import GHC.Stack.CloneStack.Types (StackEntry)
+import {-# SOURCE #-} GHC.Stack.CloneStack (cloneMyStack, decode)
+
+-- | An exception backtrace.
+--
+-- @since 4.15
+data Backtrace
+  = -- | a cost center profiler backtrace
+    CostCenterBacktrace (Ptr CostCentreStack)
+  | -- | a stack from 'GHC.Stack.HasCallStack'
+    HasCallStackBacktrace GHC.Stack.CallStack
+  | -- | a stack unwinding (e.g. DWARF) backtrace
+    ExecutionBacktrace [GHC.ExecutionStack.Location]
+  | -- | a backtrace from Info Table Provenance Entries
+    IPEBacktrace [StackEntry]
+
+-- | @since 4.15
+instance Show Backtrace where
+  -- TODO
+  showsPrec p (CostCenterBacktrace ccs) = showsPrec p ccs
+  showsPrec p (HasCallStackBacktrace ccs) = showsPrec p ccs
+  showsPrec _ (ExecutionBacktrace ccs) = showStackFrames ccs
+  showsPrec p (IPEBacktrace stackEntries) = showsPrec p stackEntries
+
+-- | How to collect a backtrace when an exception is thrown.
+data BacktraceMechanism
+  = -- | collect a cost center stacktrace (only available when built with profiling)
+    CostCenterBacktraceMech
+  | -- | use execution stack unwinding with given limit
+    ExecutionStackBacktraceMech
+  | -- | collect backtraces from Info Table Provenance Entries
+    IPEBacktraceMech
+  | -- | use 'HasCallStack'
+   HasCallStackBacktraceMech
+  deriving (Eq, Show)
+
+showBacktraces :: [Backtrace] -> String
+showBacktraces bts = List.unlines $ List.intersperse "" $ map show bts
+
+currentBacktraceMechanisms :: IORef [BacktraceMechanism]
+currentBacktraceMechanisms = unsafePerformIO $ newIORef []
+{-# NOINLINE currentBacktraceMechanisms #-}
+
+-- | Set how 'Control.Exception.throwIO', et al. collect backtraces.
+setDefaultBacktraceMechanisms :: [BacktraceMechanism] -> IO ()
+setDefaultBacktraceMechanisms = writeIORef currentBacktraceMechanisms
+
+-- | Returns the currently selected 'BacktraceMechanism'.
+getDefaultBacktraceMechanisms :: IO [BacktraceMechanism]
+getDefaultBacktraceMechanisms = readIORef currentBacktraceMechanisms
+
+-- | Collect a list of 'Backtrace' via all current default 'BacktraceMechanism'.
+-- See 'setDefaultBacktraceMechanisms'
+collectBacktraces :: HasCallStack =>IO [Backtrace]
+collectBacktraces = do
+    mechs <- getDefaultBacktraceMechanisms
+    catMaybes `fmap` mapM collectBacktraces' mechs
+  where
+    -- | Collect a 'Backtrace' via the given 'BacktraceMechanism'.
+    collectBacktraces' :: HasCallStack => BacktraceMechanism -> IO (Maybe Backtrace)
+    collectBacktraces' CostCenterBacktraceMech = collectCostCenterBacktrace
+    collectBacktraces' ExecutionStackBacktraceMech = collectExecutionStackBacktrace
+    collectBacktraces' IPEBacktraceMech = collectIPEBacktrace
+    collectBacktraces' HasCallStackBacktraceMech = collectHasCallStackBacktrace
+
+collectCostCenterBacktrace :: IO (Maybe Backtrace)
+collectCostCenterBacktrace = do
+  ptr <- getCurrentCCS ()
+  if ptr == nullPtr then
+    pure Nothing
+  else do
+    pure $ Just (CostCenterBacktrace ptr)
+
+collectExecutionStackBacktrace :: IO (Maybe Backtrace)
+collectExecutionStackBacktrace = fmap ExecutionBacktrace `fmap` getStackTrace
+
+collectIPEBacktrace :: IO (Maybe Backtrace)
+collectIPEBacktrace = do
+  stack <- cloneMyStack
+  stackEntries <- decode stack
+  pure $ Just $ IPEBacktrace stackEntries
+
+collectHasCallStackBacktrace :: HasCallStack => IO (Maybe Backtrace)
+collectHasCallStackBacktrace = pure . Just $ HasCallStackBacktrace callStack
diff --git a/libraries/base/GHC/Exception/Type.hs b/libraries/base/GHC/Exception/Type.hs
index 52a09a76f0..94b1f1e706 100644
--- a/libraries/base/GHC/Exception/Type.hs
+++ b/libraries/base/GHC/Exception/Type.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE Trustworthy #-}
-
+{-# LANGUAGE BangPatterns #-}
 {-# OPTIONS_HADDOCK not-home #-}
 
 -----------------------------------------------------------------------------
@@ -20,7 +20,8 @@
 
 module GHC.Exception.Type
        ( Exception(..)    -- Class
-       , SomeExceptionWithLocation(..), SomeException, ArithException(..)
+       , SomeExceptionWithLocation(..), SomeException(..), ArithException(..)
+        , addBacktrace
        , divZeroException, overflowException, ratioZeroDenomException
        , underflowException
        ) where
@@ -30,20 +31,39 @@ import Data.Typeable (Typeable, cast)
    -- loop: Data.Typeable -> GHC.Err -> GHC.Exception
 import GHC.Base
 import GHC.Show
+import GHC.Exception.Backtrace (Backtrace)
 
 {- |
 The @SomeExceptionWithLocation@ type is the root of the exception type hierarchy.
 When an exception of type @e@ is thrown, behind the scenes it is
-encapsulated in a @SomeExceptionWithLocation@.
+encapsulated in a @SomeException@ which is wrapped by @SomeExceptionWithLocation@.
+This additional layer is used to provide a list of 'Backtrace's.
+
+@since 4.16.0.0
 -}
-data SomeExceptionWithLocation = forall e . Exception e => SomeExceptionWithLocation e [String]
+data SomeExceptionWithLocation = SomeExceptionWithLocation !SomeException ![Backtrace]
 
-type SomeException = SomeExceptionWithLocation
+-- | Former root of 'Exception's
+-- Now 'SomeException' is usually wrapped by 'SomeExceptionWithLocation'.
+-- 'SomeException' has been kept as a type for backwards compatibility.
+data SomeException = forall e . Exception e => SomeException !e
 
--- | @since 3.0
+-- @since 4.16.0.0
 instance Show SomeExceptionWithLocation where
-    -- TODO: Print backtraces
-    showsPrec p (SomeExceptionWithLocation e _) = showsPrec p e
+    -- | Just delegate to the wrapped 'Exception' @e@.
+    showsPrec p (SomeExceptionWithLocation (SomeException e) _) = showsPrec p e
+
+-- | @since 3.0
+instance Show SomeException where
+   -- | Just delegate to the wrapped 'Exception' @e@.
+   showsPrec p (SomeException e) = showsPrec p e
+
+-- | Add a 'Backtrace' to the list of backtraces.
+--
+-- @since 4.16.0.0
+addBacktrace :: Backtrace -> SomeExceptionWithLocation -> SomeExceptionWithLocation
+addBacktrace bt (SomeExceptionWithLocation e bts) =
+    SomeExceptionWithLocation e (bt : bts)
 
 {- |
 Any type that you wish to throw or catch as an exception must be an
@@ -132,11 +152,15 @@ Caught MismatchedParentheses
 
 -}
 class (Typeable e, Show e) => Exception e where
+    -- | Represent the exception as 'SomeExceptionWithLocation'
+    -- If @e@ isn't already of type 'SomeExceptionWithLocation' this means some kind of wrapping.
     toException   :: e -> SomeExceptionWithLocation
+    -- | Extract and cast the exception from it's wrapped representation
+    -- If the exception cannot be casted to the expected type then the result is 'Nothing'.
     fromException :: SomeExceptionWithLocation -> Maybe e
 
-    toException e = SomeExceptionWithLocation e []
-    fromException (SomeExceptionWithLocation e _) = cast e
+    toException e = SomeExceptionWithLocation (SomeException e) []
+    fromException (SomeExceptionWithLocation (SomeException e) _) = cast e
 
     -- | Render this exception value in a human-friendly manner.
     --
@@ -146,7 +170,10 @@ class (Typeable e, Show e) => Exception e where
     displayException :: e -> String
     displayException = show
 
--- | @since 3.0
+instance Exception SomeException where
+  toException e = SomeExceptionWithLocation e []
+  fromException (SomeExceptionWithLocation e _) = Just e
+
 instance Exception SomeExceptionWithLocation where
     toException se = se
     fromException = Just
diff --git a/libraries/base/GHC/Exception/Type.hs-boot b/libraries/base/GHC/Exception/Type.hs-boot
index 0d6d48635a..6ac1722e2c 100644
--- a/libraries/base/GHC/Exception/Type.hs-boot
+++ b/libraries/base/GHC/Exception/Type.hs-boot
@@ -7,6 +7,7 @@ module GHC.Exception.Type
   , overflowException
   , ratioZeroDenomException
   , underflowException
+  , Exception
   ) where
 
 import GHC.Num.Integer ()   -- See Note [Depend on GHC.Num.Integer] in GHC.Base
@@ -14,3 +15,7 @@ import GHC.Num.Integer ()   -- See Note [Depend on GHC.Num.Integer] in GHC.Base
 data SomeExceptionWithLocation
 divZeroException, overflowException,
   ratioZeroDenomException, underflowException :: SomeExceptionWithLocation
+
+class Exception e
+
+instance Exception SomeExceptionWithLocation
diff --git a/libraries/base/GHC/ExecutionStack.hs-boot b/libraries/base/GHC/ExecutionStack.hs-boot
new file mode 100644
index 0000000000..7f2761df53
--- /dev/null
+++ b/libraries/base/GHC/ExecutionStack.hs-boot
@@ -0,0 +1,12 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.ExecutionStack
+  ( Location,
+    getStackTrace,
+  )
+where
+
+import GHC.Base
+import {-# SOURCE #-} GHC.ExecutionStack.Internal (Location)
+
+getStackTrace :: IO (Maybe [Location])
diff --git a/libraries/base/GHC/ExecutionStack/Internal.hs-boot b/libraries/base/GHC/ExecutionStack/Internal.hs-boot
new file mode 100644
index 0000000000..1ecfb9f159
--- /dev/null
+++ b/libraries/base/GHC/ExecutionStack/Internal.hs-boot
@@ -0,0 +1,9 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.ExecutionStack.Internal where
+
+import GHC.Show (ShowS)
+
+data Location
+
+showStackFrames :: [Location] -> ShowS
diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs
index be7f99b2cd..9a5bae9704 100644
--- a/libraries/base/GHC/IO.hs
+++ b/libraries/base/GHC/IO.hs
@@ -39,10 +39,16 @@ module GHC.IO (
         MaskingState(..), getMaskingState,
         unsafeUnmask, interruptible,
         onException, bracket, finally, evaluate,
-        mkUserError
+        throwIOUserError,
+        throwIOWithCallStack,
+        throwIOWithBacktraceMechanism,
+        throwIOWithIPEStack,
+        throwIOWithCostCenterStack,
+        throwIOWithExecutionStack
     ) where
 
 import GHC.Base
+import GHC.List
 import GHC.ST
 import GHC.Exception
 import GHC.Show
@@ -50,6 +56,13 @@ import GHC.IO.Unsafe
 import Unsafe.Coerce ( unsafeCoerce )
 
 import {-# SOURCE #-} GHC.IO.Exception ( userError, IOError )
+import GHC.Exception.Backtrace ( Backtrace
+                                , collectBacktraces
+                                , collectHasCallStackBacktrace
+                                , collectIPEBacktrace
+                                , collectCostCenterBacktrace
+                                , collectExecutionStackBacktrace )
+import {-# SOURCE #-} GHC.Stack ( HasCallStack )
 
 -- ---------------------------------------------------------------------------
 -- The IO Monad
@@ -184,7 +197,7 @@ catch   :: Exception e
 catch (IO io) handler = IO $ catch# io handler'
     where handler' e = case fromException e of
                        Just e' -> unIO (handler e')
-                       Nothing -> raiseIO# e
+                       Nothing -> unIO $ throwIO e
 
 
 -- | Catch any 'Exception' type in the 'IO' monad.
@@ -194,7 +207,7 @@ catch (IO io) handler = IO $ catch# io handler'
 -- details.
 catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a
 catchAny !(IO io) handler = IO $ catch# io handler'
-    where handler' (SomeExceptionWithLocation e _) = unIO (handler e)
+    where handler' (SomeExceptionWithLocation (SomeException e) _) = unIO (handler e)
 
 -- Using catchException here means that if `m` throws an
 -- 'IOError' /as an imprecise exception/, we will not catch
@@ -203,6 +216,8 @@ mplusIO :: IO a -> IO a -> IO a
 mplusIO m n = m `catchException` \ (_ :: IOError) -> n
 
 -- | A variant of 'throw' that can only be used within the 'IO' monad.
+-- 'Backtrace' backtraces are collected according to the configured
+-- 'BacktraceMechanism's.
 --
 -- Although 'throwIO' has a type that is an instance of the type of 'throw', the
 -- two functions are subtly different:
@@ -217,9 +232,57 @@ mplusIO m n = m `catchException` \ (_ :: IOError) -> n
 -- raise an exception within the 'IO' monad because it guarantees
 -- ordering with respect to other 'IO' operations, whereas 'throw'
 -- does not.
-throwIO :: Exception e => e -> IO a
-throwIO e = IO (raiseIO# (toException e))
-
+throwIO :: (HasCallStack, Exception e) => e -> IO a
+throwIO e = do
+    let e'@(SomeExceptionWithLocation _ !bts) = toException e
+    !bts' <- if null bts then
+      collectBacktraces
+    else
+      pure bts
+
+    let !e'' = foldr addBacktrace e' bts'
+    IO(raiseIO# e'')
+
+-- | Throw an exception with a 'Backtrace' gathered by the 'HasCallStackBacktraceMech' mechanism.
+-- If the exception already has backtraces, the new one is added.
+throwIOWithCallStack :: (HasCallStack, Exception e) => e -> IO a
+throwIOWithCallStack e =
+-- throwIOWithCallStack cannot call throwWithBacktraceMechanism because that would introduce
+-- unnecessary HasCallStack constraints (that would decrease performance).
+   let
+      !maybeBt = unsafePerformIO collectHasCallStackBacktrace
+      !e' = case maybeBt of
+              Just bt -> addBacktrace bt $ toException e
+              Nothing -> toException e
+    in
+      IO(raiseIO# e')
+
+throwIOWithBacktraceMechanism :: Exception e => IO (Maybe Backtrace) -> e -> IO a
+throwIOWithBacktraceMechanism mech e = let
+      !maybeBt = unsafePerformIO mech
+      !e' = case maybeBt of
+              Just bt -> addBacktrace bt $ toException e
+              Nothing -> toException e
+    in
+      IO(raiseIO# e')
+
+-- | Throw an exception with a 'Backtrace' gathered by the 'IPEBacktraceMech' mechanism.
+-- If the exception already has backtraces, the new one is added.
+throwIOWithIPEStack :: Exception e => e -> IO a
+throwIOWithIPEStack = throwIOWithBacktraceMechanism collectIPEBacktrace
+
+-- | Throw an exception with a 'Backtrace' gathered by the 'CostCenterBacktraceMech' mechanism.
+-- If the exception already has backtraces, the new one is added.
+throwIOWithCostCenterStack :: Exception e => e -> IO a
+throwIOWithCostCenterStack = throwIOWithBacktraceMechanism collectCostCenterBacktrace
+
+-- | Throw an exception with a 'Backtrace' gathered by the 'ExecutionStackBacktraceMech' mechanism.
+-- If the exception already has backtraces, the new one is added.
+throwIOWithExecutionStack :: Exception e => e -> IO a
+throwIOWithExecutionStack = throwIOWithBacktraceMechanism collectExecutionStackBacktrace
+
+throwIOUserError :: String -> IO a
+throwIOUserError s = throwIO $ userError s
 -- -----------------------------------------------------------------------------
 -- Controlling asynchronous exception delivery
 
@@ -456,7 +519,3 @@ Since this strictness is a small optimization and may lead to surprising
 results, all of the @catch@ and @handle@ variants offered by "Control.Exception"
 use 'catch' rather than 'catchException'.
 -}
-
--- For SOURCE import by GHC.Base to define failIO.
-mkUserError       :: [Char]  -> SomeExceptionWithLocation
-mkUserError str   = toException (userError str)
diff --git a/libraries/base/GHC/IO.hs-boot b/libraries/base/GHC/IO.hs-boot
index 9dc5003b4f..e61e2da350 100644
--- a/libraries/base/GHC/IO.hs-boot
+++ b/libraries/base/GHC/IO.hs-boot
@@ -1,10 +1,14 @@
 {-# LANGUAGE Unsafe #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module GHC.IO where
+module GHC.IO(
+    IO(..),
+    mplusIO,
+    throwIOUserError
+) where
 
 import GHC.Types
-import {-# SOURCE #-} GHC.Exception.Type (SomeExceptionWithLocation)
+import {-# SOURCE #-} GHC.Base (String)
 
 mplusIO :: IO a -> IO a -> IO a
-mkUserError :: [Char] -> SomeExceptionWithLocation
+throwIOUserError :: String -> IO a
diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs
index 152177434a..fefc2dc955 100644
--- a/libraries/base/GHC/IO/Exception.hs
+++ b/libraries/base/GHC/IO/Exception.hs
@@ -43,7 +43,7 @@ module GHC.IO.Exception (
   userError,
   assertError,
   unsupportedOperation,
-  untangle,
+  untangle
  ) where
 
 import GHC.Base
diff --git a/libraries/base/GHC/IORef.hs-boot b/libraries/base/GHC/IORef.hs-boot
new file mode 100644
index 0000000000..6e5ad1632c
--- /dev/null
+++ b/libraries/base/GHC/IORef.hs-boot
@@ -0,0 +1,11 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.IORef where
+
+import GHC.Base
+
+data IORef a
+
+newIORef :: a -> IO (IORef a)
+readIORef :: IORef a -> IO a
+writeIORef :: IORef a -> a -> IO ()
diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs
index e8cfbfbc57..5e76ec91f5 100644
--- a/libraries/base/GHC/Real.hs
+++ b/libraries/base/GHC/Real.hs
@@ -29,7 +29,8 @@ import GHC.Enum
 import GHC.Show
 import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException
                                    , underflowException
-                                   , ratioZeroDenomException )
+                                   , ratioZeroDenomException
+                                   , throw )
 
 import GHC.Num.BigNat (gcdInt,gcdWord)
 
@@ -60,19 +61,19 @@ so INLINE[2] seems sufficient.  c.f. #20709
 
 {-# NOINLINE divZeroError #-}
 divZeroError :: a
-divZeroError = raise# divZeroException
+divZeroError = throw divZeroException
 
 {-# NOINLINE ratioZeroDenominatorError #-}
 ratioZeroDenominatorError :: a
-ratioZeroDenominatorError = raise# ratioZeroDenomException
+ratioZeroDenominatorError = throw ratioZeroDenomException
 
 {-# NOINLINE overflowError #-}
 overflowError :: a
-overflowError = raise# overflowException
+overflowError = throw overflowException
 
 {-# NOINLINE underflowError #-}
 underflowError :: a
-underflowError = raise# underflowException
+underflowError = throw underflowException
 
 
 --------------------------------------------------------------
diff --git a/libraries/base/GHC/Stack.hs-boot b/libraries/base/GHC/Stack.hs-boot
new file mode 100644
index 0000000000..5dc06e85b9
--- /dev/null
+++ b/libraries/base/GHC/Stack.hs-boot
@@ -0,0 +1,7 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.Stack (CallStack, HasCallStack, callStack) where
+
+import GHC.Stack.Types
+
+callStack :: HasCallStack => CallStack
diff --git a/libraries/base/GHC/Stack/CCS.hs-boot b/libraries/base/GHC/Stack/CCS.hs-boot
index 1ac7876921..78da3ab99a 100644
--- a/libraries/base/GHC/Stack/CCS.hs-boot
+++ b/libraries/base/GHC/Stack/CCS.hs-boot
@@ -12,5 +12,14 @@ module GHC.Stack.CCS where
 -}
 
 import GHC.Base
+import GHC.Ptr
 
 currentCallStack :: IO [String]
+
+getCurrentCCS :: dummy -> IO (Ptr CostCentreStack)
+
+ccsToStrings :: Ptr CostCentreStack -> IO [String]
+
+renderStack :: [String] -> String
+
+data CostCentreStack
diff --git a/libraries/base/GHC/Stack/CloneStack.hs b/libraries/base/GHC/Stack/CloneStack.hs
index f06ecad070..ce9c36985c 100644
--- a/libraries/base/GHC/Stack/CloneStack.hs
+++ b/libraries/base/GHC/Stack/CloneStack.hs
@@ -30,6 +30,7 @@ import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofA
 import GHC.IO (IO (..))
 import GHC.Stack.CCS (InfoProv (..), InfoProvEnt, ipeProv, peekInfoProv)
 import GHC.Stable
+import GHC.Stack.CloneStack.Types
 
 -- | A frozen snapshot of the state of an execution stack.
 --
@@ -201,16 +202,6 @@ cloneThreadStack (ThreadId tid#) = do
   freeStablePtr boxedPtr
   takeMVar resultVar
 
--- | Represetation for the source location where a return frame was pushed on the stack.
--- This happens every time when a @case ... of@ scrutinee is evaluated.
-data StackEntry = StackEntry
-  { functionName :: String,
-    moduleName :: String,
-    srcLoc :: String,
-    closureType :: Word
-  }
-  deriving (Show, Eq)
-
 -- | Decode a 'StackSnapshot' to a stacktrace (a list of 'StackEntry').
 -- The stack trace is created from return frames with according 'InfoProvEnt'
 -- entries. To generate them, use the GHC flag @-finfo-table-map@. If there are
diff --git a/libraries/base/GHC/Stack/CloneStack.hs-boot b/libraries/base/GHC/Stack/CloneStack.hs-boot
new file mode 100644
index 0000000000..bec742a459
--- /dev/null
+++ b/libraries/base/GHC/Stack/CloneStack.hs-boot
@@ -0,0 +1,12 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.Stack.CloneStack where
+
+import {-# SOURCE #-} GHC.IO (IO (..))
+import GHC.Stack.CloneStack.Types
+
+data StackSnapshot
+
+cloneMyStack :: IO StackSnapshot
+
+decode :: StackSnapshot -> IO [StackEntry]
diff --git a/libraries/base/GHC/Stack/CloneStack/Types.hs b/libraries/base/GHC/Stack/CloneStack/Types.hs
new file mode 100644
index 0000000000..a575b78809
--- /dev/null
+++ b/libraries/base/GHC/Stack/CloneStack/Types.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.Stack.CloneStack.Types where
+
+import GHC.Base
+import GHC.Show
+
+-- | Represetation for the source location where a return frame was pushed on the stack.
+-- This happens every time when a @case ... of@ scrutinee is evaluated.
+data StackEntry = StackEntry
+  { functionName :: String,
+    moduleName :: String,
+    srcLoc :: String,
+    closureType :: Word
+  }
+  deriving (Show, Eq)
+
+pprStackEntry :: StackEntry -> String
+pprStackEntry se =
+  foldr
+    (++)
+    ""
+    [ moduleName se,
+      ".",
+      functionName se,
+      ":",
+      " ",
+      srcLoc se
+    ]
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 017b97081d..bc4295b5f6 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -205,6 +205,7 @@ Library
         GHC.Err
         GHC.Event.TimeOut
         GHC.Exception
+        GHC.Exception.Backtrace
         GHC.Exception.Type
         GHC.ExecutionStack
         GHC.ExecutionStack.Internal
@@ -267,6 +268,7 @@ Library
         GHC.RTS.Flags
         GHC.ST
         GHC.Stack.CloneStack
+        GHC.Stack.CloneStack.Types
         GHC.StaticPtr
         GHC.STRef
         GHC.Show
diff --git a/libraries/base/tests/GHC/Exception/Backtrace/SetAndGetBacktraceMechanisms.hs b/libraries/base/tests/GHC/Exception/Backtrace/SetAndGetBacktraceMechanisms.hs
new file mode 100644
index 0000000000..d3443e3d15
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/Backtrace/SetAndGetBacktraceMechanisms.hs
@@ -0,0 +1,38 @@
+module Main where
+
+import GHC.Exception.Backtrace
+import System.Exit (die)
+import Prelude
+
+main = do
+  expectDefaultBacktraceMechanisms []
+
+  setAndExpectDefaultBacktraceMechanisms []
+
+  setAndExpectDefaultBacktraceMechanisms [CostCenterBacktraceMech]
+
+  setAndExpectDefaultBacktraceMechanisms [ExecutionStackBacktraceMech]
+
+  setAndExpectDefaultBacktraceMechanisms
+    [ CostCenterBacktraceMech,
+      ExecutionStackBacktraceMech
+    ]
+
+  setAndExpectDefaultBacktraceMechanisms
+    [ CostCenterBacktraceMech,
+      ExecutionStackBacktraceMech,
+      HasCallStackBacktraceMech,
+      IPEBacktraceMech
+    ]
+
+setAndExpectDefaultBacktraceMechanisms :: [BacktraceMechanism] -> IO ()
+setAndExpectDefaultBacktraceMechanisms bts = do
+  setDefaultBacktraceMechanisms bts
+  expectDefaultBacktraceMechanisms bts
+
+expectDefaultBacktraceMechanisms :: [BacktraceMechanism] -> IO ()
+expectDefaultBacktraceMechanisms expected = do
+  ms <- getDefaultBacktraceMechanisms
+  if ms /= expected
+    then die $ "Expected " ++ show expected ++ " as default backtrace mechanisms, but got: " ++ show ms
+    else return ()
diff --git a/libraries/base/tests/GHC/Exception/Backtrace/all.T b/libraries/base/tests/GHC/Exception/Backtrace/all.T
new file mode 100644
index 0000000000..4820b11ddb
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/Backtrace/all.T
@@ -0,0 +1 @@
+test('SetAndGetBacktraceMechanisms', normal, compile_and_run, [''])
diff --git a/libraries/base/tests/GHC/Exception/Backtrace/collectBacktraces.stdout b/libraries/base/tests/GHC/Exception/Backtrace/collectBacktraces.stdout
new file mode 100644
index 0000000000..c540e1d5a1
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/Backtrace/collectBacktraces.stdout
@@ -0,0 +1 @@
+[[StackEntry {functionName = "collectBacktracesInScrutinee", moduleName = "Main", srcLoc = "collectBacktraces.hs:(19,1)-(26,35)", closureType = 53},StackEntry {functionName = "collectBacktracesInScrutinee.scrutinee", moduleName = "Main", srcLoc = "collectBacktraces.hs:25:37-53", closureType = 53}],[("collectHasCallStackBacktrace",SrcLoc {srcLocPackage = "base", srcLocModule = "GHC.Exception.Backtrace", srcLocFile = "libraries/base/GHC/Exception/Backtrace.hs", srcLocStartLine = 109, srcLocStartCol = 52, srcLocEndLine = 109, srcLocEndCol = 80}),("collectBacktraces'",SrcLoc {srcLocPackage = "base", srcLocModule = "GHC.Exception.Backtrace", srcLocFile = "libraries/base/GHC/Exception/Backtrace.hs", srcLocStartLine = 102, srcLocStartCol = 27, srcLocEndLine = 102, srcLocEndCol = 45}),("collectBacktraces",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "collectBacktraces.hs", srcLocStartLine = 25, srcLocStartCol = 37, srcLocEndLine = 25, srcLocEndCol = 54})],["Main.CAF (<entire-module>)","Main.collectBacktracesInScrutinee (collectBacktraces.hs:(19,1)-(26,35))","Main.collectBacktracesInScrutinee.scrutinee (collectBacktraces.hs:(25,5)-(26,35))"]]
diff --git a/libraries/base/tests/GHC/Exception/SomeExceptionWithLocationType.hs b/libraries/base/tests/GHC/Exception/SomeExceptionWithLocationType.hs
new file mode 100644
index 0000000000..d19523cab1
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/SomeExceptionWithLocationType.hs
@@ -0,0 +1,27 @@
+module Main where
+
+import Control.Exception
+import GHC.Exception
+import GHC.Exception.Backtrace
+
+data CustomException = CustomException deriving (Show)
+
+instance Exception CustomException
+
+main :: IO ()
+main = do
+  print "=== Test Show instances ==="
+  print "SomeExceptionWithLocation:"
+  catch
+    (throw CustomException)
+    (\(e :: SomeExceptionWithLocation) -> print e)
+
+  print "SomeException:"
+  catch
+    (throw CustomException)
+    (\(e :: SomeException) -> print e)
+
+  print "CustomException:"
+  catch
+    (throw CustomException)
+    (\(e :: CustomException) -> print e)
diff --git a/libraries/base/tests/GHC/Exception/SomeExceptionWithLocationType.stdout b/libraries/base/tests/GHC/Exception/SomeExceptionWithLocationType.stdout
new file mode 100644
index 0000000000..ca6a2570d3
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/SomeExceptionWithLocationType.stdout
@@ -0,0 +1,7 @@
+"=== Test Show instances ==="
+"SomeExceptionWithLocation:"
+CustomException
+"SomeException:"
+CustomException
+"CustomException:"
+CustomException
diff --git a/libraries/base/tests/GHC/Exception/ThrowTestLib.hs b/libraries/base/tests/GHC/Exception/ThrowTestLib.hs
new file mode 100644
index 0000000000..eff209f291
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/ThrowTestLib.hs
@@ -0,0 +1,62 @@
+module ThrowTestLib
+  ( runThrowTest,
+    CustomException,
+  )
+where
+
+import Control.Exception
+import GHC.Exception
+import GHC.Exception.Backtrace
+import GHC.Exception.Type
+import GHC.IO.Unsafe
+
+data CustomException = CustomException1 | CustomException2 | CustomException3 | CustomException4 deriving (Show)
+
+instance Exception CustomException
+
+runThrowTest :: (CustomException -> IO Int) -> IO ()
+runThrowTest throwFunction = do
+  print "=== Test backtraces ==="
+  printBacktrace throwFunction [] 0 CustomException1
+  printBacktrace throwFunction [HasCallStackBacktraceMech] 0 CustomException1
+  printBacktrace throwFunction [CostCenterBacktraceMech] 0 CustomException2
+  -- ExecutionStackBacktraceMech unfortunately crashes unless GHC was
+  -- configured with '--enable-dwarf-unwind'.
+  -- printBacktrace [ExecutionStackBacktraceMech]
+  printBacktrace throwFunction [IPEBacktraceMech] 1 CustomException3
+  printBacktrace
+    throwFunction
+    [ IPEBacktraceMech,
+      CostCenterBacktraceMech,
+      HasCallStackBacktraceMech
+    ]
+    2
+    CustomException4
+
+printBacktrace :: (CustomException -> IO Int) -> [BacktraceMechanism] -> Int -> CustomException -> IO ()
+printBacktrace throwFunction mechs deepness e = do
+  print $ "Backtrace mechanisms " ++ show mechs ++ ":"
+  setDefaultBacktraceMechanisms mechs
+  _ <-
+    catch
+      (produceDeepStack throwFunction deepness e)
+      (\e -> printBacktraces e >> pure 42)
+  pure ()
+
+printBacktraces :: SomeExceptionWithLocation -> IO ()
+printBacktraces = putStrLn . pprBacktraces
+
+-- Force creation of Stg stack return frames for IPE based backtraces.
+produceDeepStack :: (CustomException -> IO Int) -> Int -> CustomException -> IO Int
+produceDeepStack throwFunction deepness e = case unsafePerformIO $ getDeepStackCase deepness e of
+  -- Due to the thrown exception, the cases below are never hit!
+  -- But we need to include some "noise" here, such that GHC doesn't simplify
+  -- the case expression away.
+  0 -> pure 42
+  i -> pure i
+  where
+    -- Get the exception to throw as parameter, so that GHC cannot use an
+    -- already evaluated thunk from a prior execution.
+    getDeepStackCase :: Int -> CustomException -> IO Int
+    getDeepStackCase 0 e = throwFunction e
+    getDeepStackCase n e = getDeepStackCase (n - 1) e
diff --git a/libraries/base/tests/GHC/Exception/all.T b/libraries/base/tests/GHC/Exception/all.T
new file mode 100644
index 0000000000..7b1b83d784
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/all.T
@@ -0,0 +1,7 @@
+test('throw', [only_ways(prof_ways), extra_files(['ThrowTestLib.hs'])], compile_and_run, ['-finfo-table-map -prof'])
+test('throw_rethrowException', normal, compile_and_run, [''])
+test('SomeExceptionWithLocationType', normal, compile_and_run, [''])
+test('throwWithCallStack', [when(opsys('mingw32'), skip)], compile_and_run, [''])
+test('throwWithCallStack_Windows', [unless(opsys('mingw32'), skip)], compile_and_run, [''])
+test('throwWithCostCenterStack', [only_ways(prof_ways)], compile_and_run, ['-prof'])
+test('throwWithIPEStack', normal, compile_and_run, ['-finfo-table-map'])
diff --git a/libraries/base/tests/GHC/Exception/throw.hs b/libraries/base/tests/GHC/Exception/throw.hs
new file mode 100644
index 0000000000..0fb16400fb
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/throw.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import ThrowTestLib
+import GHC.Exception
+
+main = runThrowTest throw
diff --git a/libraries/base/tests/GHC/Exception/throw.stdout b/libraries/base/tests/GHC/Exception/throw.stdout
new file mode 100644
index 0000000000..06c3c3ae21
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/throw.stdout
@@ -0,0 +1,39 @@
+"=== Test backtraces ==="
+"Backtrace mechanisms []:"
+
+"Backtrace mechanisms [HasCallStackBacktraceMech]:"
+HasCallStack backtrace:
+ CallStack (from HasCallStack):
+   collectHasCallStackBacktrace, called at libraries/base/GHC/Exception/Backtrace.hs:109:52 in base:GHC.Exception.Backtrace
+   collectBacktraces', called at libraries/base/GHC/Exception/Backtrace.hs:102:27 in base:GHC.Exception.Backtrace
+   collectBacktraces, called at libraries/base/GHC/Exception.hs:68:30 in base:GHC.Exception
+   throw, called at throw.hs:6:21 in main:Main
+"Backtrace mechanisms [CostCenterBacktraceMech]:"
+Cost Centre backtrace:
+ ThrowTestLib.produceDeepStack.getDeepStackCase (ThrowTestLib.hs:(61,5)-(62,53))
+ ThrowTestLib.produceDeepStack (ThrowTestLib.hs:(51,1)-(62,53))
+ ThrowTestLib.printBacktrace (ThrowTestLib.hs:(37,1)-(44,9))
+ ThrowTestLib.runThrowTest (ThrowTestLib.hs:(18,1)-(34,20))
+ Main.main (throw.hs:6:1-25)
+"Backtrace mechanisms [IPEBacktraceMech]:"
+Info Table Provenance Entries (IPE) backtrace:
+ ThrowTestLib.runThrowTest: ThrowTestLib.hs:26:18-30
+ ThrowTestLib.printBacktrace: ThrowTestLib.hs:(41,5)-(43,42)
+ ThrowTestLib.printBacktrace: ThrowTestLib.hs:42:48
+"Backtrace mechanisms [IPEBacktraceMech,CostCenterBacktraceMech,HasCallStackBacktraceMech]:"
+Info Table Provenance Entries (IPE) backtrace:
+ ThrowTestLib.runThrowTest: ThrowTestLib.hs:28:5-17
+ ThrowTestLib.printBacktrace: ThrowTestLib.hs:(41,5)-(43,42)
+ ThrowTestLib.printBacktrace: ThrowTestLib.hs:42:48
+Cost Centre backtrace:
+ ThrowTestLib.produceDeepStack.getDeepStackCase (ThrowTestLib.hs:(61,5)-(62,53))
+ ThrowTestLib.produceDeepStack (ThrowTestLib.hs:(51,1)-(62,53))
+ ThrowTestLib.printBacktrace (ThrowTestLib.hs:(37,1)-(44,9))
+ ThrowTestLib.runThrowTest (ThrowTestLib.hs:(18,1)-(34,20))
+ Main.main (throw.hs:6:1-25)
+HasCallStack backtrace:
+ CallStack (from HasCallStack):
+   collectHasCallStackBacktrace, called at libraries/base/GHC/Exception/Backtrace.hs:109:52 in base:GHC.Exception.Backtrace
+   collectBacktraces', called at libraries/base/GHC/Exception/Backtrace.hs:102:27 in base:GHC.Exception.Backtrace
+   collectBacktraces, called at libraries/base/GHC/Exception.hs:68:30 in base:GHC.Exception
+   throw, called at throw.hs:6:21 in main:Main
diff --git a/libraries/base/tests/GHC/Exception/throwWithCallStack.hs b/libraries/base/tests/GHC/Exception/throwWithCallStack.hs
new file mode 100644
index 0000000000..c2ff88944a
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/throwWithCallStack.hs
@@ -0,0 +1,16 @@
+module Main where
+
+import Control.Exception
+import GHC.Exception
+
+data CustomException = CustomException deriving (Show)
+
+instance Exception CustomException
+
+main :: IO ()
+main =
+  catch
+    (throwWithCallStack CustomException)
+    printBacktraces
+  where
+    printBacktraces = putStr . pprBacktraces
diff --git a/libraries/base/tests/GHC/Exception/throwWithCallStack.stdout b/libraries/base/tests/GHC/Exception/throwWithCallStack.stdout
new file mode 100644
index 0000000000..d17ac58c89
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/throwWithCallStack.stdout
@@ -0,0 +1,4 @@
+HasCallStack backtrace:
+ CallStack (from HasCallStack):
+   collectHasCallStackBacktrace, called at libraries/base/GHC/Exception.hs:83:15 in base:GHC.Exception
+   throwWithCallStack, called at throwWithCallStack.hs:13:8 in main:Main
\ No newline at end of file
diff --git a/libraries/base/tests/GHC/Exception/throwWithCallStack_Windows.hs b/libraries/base/tests/GHC/Exception/throwWithCallStack_Windows.hs
new file mode 100644
index 0000000000..c2ff88944a
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/throwWithCallStack_Windows.hs
@@ -0,0 +1,16 @@
+module Main where
+
+import Control.Exception
+import GHC.Exception
+
+data CustomException = CustomException deriving (Show)
+
+instance Exception CustomException
+
+main :: IO ()
+main =
+  catch
+    (throwWithCallStack CustomException)
+    printBacktraces
+  where
+    printBacktraces = putStr . pprBacktraces
diff --git a/libraries/base/tests/GHC/Exception/throwWithCallStack_Windows.stdout b/libraries/base/tests/GHC/Exception/throwWithCallStack_Windows.stdout
new file mode 100644
index 0000000000..6921a66549
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/throwWithCallStack_Windows.stdout
@@ -0,0 +1,4 @@
+HasCallStack backtrace:
+ CallStack (from HasCallStack):
+   collectHasCallStackBacktrace, called at libraries/base/GHC/Exception.hs:83:15 in base:GHC.Exception
+   throwWithCallStack, called at throwWithCallStack_Windows.hs:<line>:<column> in <package-id>:Main
diff --git a/libraries/base/tests/GHC/Exception/throwWithCostCenterStack.hs b/libraries/base/tests/GHC/Exception/throwWithCostCenterStack.hs
new file mode 100644
index 0000000000..daa8b306ed
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/throwWithCostCenterStack.hs
@@ -0,0 +1,16 @@
+module Main where
+
+import Control.Exception
+import GHC.Exception
+
+data CustomException = CustomException deriving (Show)
+
+instance Exception CustomException
+
+main :: IO ()
+main =
+  catch
+    (throwWithCostCenterStack CustomException)
+    printBacktraces
+  where
+    printBacktraces = putStr . pprBacktraces
diff --git a/libraries/base/tests/GHC/Exception/throwWithCostCenterStack.stdout b/libraries/base/tests/GHC/Exception/throwWithCostCenterStack.stdout
new file mode 100644
index 0000000000..4a44bd36cf
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/throwWithCostCenterStack.stdout
@@ -0,0 +1,3 @@
+Cost Centre backtrace:
+ Main.main (throwWithCostCenterStack.hs:(11,1)-(16,44))
+ Main.CAF (<entire-module>)
\ No newline at end of file
diff --git a/libraries/base/tests/GHC/Exception/throwWithIPEStack.hs b/libraries/base/tests/GHC/Exception/throwWithIPEStack.hs
new file mode 100644
index 0000000000..5553f849d5
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/throwWithIPEStack.hs
@@ -0,0 +1,27 @@
+module Main where
+
+import Control.Exception
+import GHC.Exception
+
+data CustomException = CustomException deriving (Show)
+
+instance Exception CustomException
+
+main :: IO ()
+main = do
+  catch
+    (throwExceptionInScrutinee 1 >> pure ())
+    printBacktraces
+  where
+    printBacktraces = putStr . pprBacktraces
+
+-- Force creation of Stg stack return frames for IPE based backtraces.
+throwExceptionInScrutinee :: Int -> IO Int
+throwExceptionInScrutinee deepness = case scrutinee deepness of
+  -- Due the the thrown exception, the cases below are never hit!
+  0 -> pure 42
+  i -> pure i
+  where
+    scrutinee :: Int -> Int
+    scrutinee 0 = throwWithIPEStack CustomException
+    scrutinee n = scrutinee $ n - 1
diff --git a/libraries/base/tests/GHC/Exception/throwWithIPEStack.stdout b/libraries/base/tests/GHC/Exception/throwWithIPEStack.stdout
new file mode 100644
index 0000000000..627d35cdb2
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/throwWithIPEStack.stdout
@@ -0,0 +1,2 @@
+Info Table Provenance Entries (IPE) backtrace:
+ Main.throwExceptionInScrutinee: throwWithIPEStack.hs:20:53-60
\ No newline at end of file
diff --git a/libraries/base/tests/GHC/Exception/throw_rethrowException.hs b/libraries/base/tests/GHC/Exception/throw_rethrowException.hs
new file mode 100644
index 0000000000..077d230d66
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/throw_rethrowException.hs
@@ -0,0 +1,33 @@
+module Main where
+
+import Control.Exception
+import GHC.Exception
+import GHC.Exception.Backtrace
+import System.Exit
+
+data CustomException = CustomException deriving (Show)
+
+instance Exception CustomException
+
+-- When an exception is thrown more than one times, it keeps the first backtrace.
+-- This test shares almost all code with GHC/IO/throwIO_rethrowException.hs.
+-- Unfortunately, the test function cannot be parameterized over the throw* function,
+-- because that would change the backtrace in an unsuable manner.
+main :: IO ()
+main = do
+  setDefaultBacktraceMechanisms [HasCallStackBacktraceMech]
+  catch
+    ( catch
+        -- Throw for the first time.
+        (throw CustomException)
+        -- Throw for the second time.
+        (\(e :: SomeExceptionWithLocation) -> throw e)
+    )
+    ( \(e :: SomeExceptionWithLocation) -> case e of
+        (SomeExceptionWithLocation _ bts) ->
+          case head bts of
+            -- Only print the most significant location; i.e. the location
+            -- where throw was called.
+            HasCallStackBacktrace cs -> print $ last $ getCallStack cs
+            _ -> exitFailure
+    )
diff --git a/libraries/base/tests/GHC/Exception/throw_rethrowException.stdout b/libraries/base/tests/GHC/Exception/throw_rethrowException.stdout
new file mode 100644
index 0000000000..3d68f265df
--- /dev/null
+++ b/libraries/base/tests/GHC/Exception/throw_rethrowException.stdout
@@ -0,0 +1 @@
+("throw",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "throw_rethrowException.hs", srcLocStartLine = 22, srcLocStartCol = 10, srcLocEndLine = 22, srcLocEndCol = 15})
diff --git a/libraries/base/tests/GHC/IO/all.T b/libraries/base/tests/GHC/IO/all.T
new file mode 100644
index 0000000000..0d83cf117d
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/all.T
@@ -0,0 +1,6 @@
+test('throwIO', [only_ways(prof_ways), extra_files(['../Exception/ThrowTestLib.hs'])], compile_and_run, ['-finfo-table-map -prof'])
+test('throwIO_rethrowException', normal, compile_and_run, [''])
+test('throwIOWithCallStack', [when(opsys('mingw32'), skip)], compile_and_run, [''])
+test('throwIOWithCallStack_Windows', [unless(opsys('mingw32'), skip)], compile_and_run, [''])
+test('throwIOWithCostCenterStack', [only_ways(prof_ways)], compile_and_run, ['-prof'])
+test('throwIOWithIPEStack', normal, compile_and_run, ['-finfo-table-map'])
diff --git a/libraries/base/tests/GHC/IO/throwIO.hs b/libraries/base/tests/GHC/IO/throwIO.hs
new file mode 100644
index 0000000000..532de3fd97
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/throwIO.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import GHC.IO
+import ThrowTestLib
+
+main = runThrowTest throwIO
diff --git a/libraries/base/tests/GHC/IO/throwIO.stdout b/libraries/base/tests/GHC/IO/throwIO.stdout
new file mode 100644
index 0000000000..de170586f8
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/throwIO.stdout
@@ -0,0 +1,39 @@
+"=== Test backtraces ==="
+"Backtrace mechanisms []:"
+
+"Backtrace mechanisms [HasCallStackBacktraceMech]:"
+HasCallStack backtrace:
+ CallStack (from HasCallStack):
+   collectHasCallStackBacktrace, called at libraries/base/GHC/Exception/Backtrace.hs:109:52 in base:GHC.Exception.Backtrace
+   collectBacktraces', called at libraries/base/GHC/Exception/Backtrace.hs:102:27 in base:GHC.Exception.Backtrace
+   collectBacktraces, called at libraries/base/GHC/IO.hs:239:7 in base:GHC.IO
+   throwIO, called at throwIO.hs:6:21 in main:Main
+"Backtrace mechanisms [CostCenterBacktraceMech]:"
+Cost Centre backtrace:
+ ThrowTestLib.produceDeepStack.getDeepStackCase (ThrowTestLib.hs:(61,5)-(62,53))
+ ThrowTestLib.produceDeepStack (ThrowTestLib.hs:(51,1)-(62,53))
+ ThrowTestLib.printBacktrace (ThrowTestLib.hs:(37,1)-(44,9))
+ ThrowTestLib.runThrowTest (ThrowTestLib.hs:(18,1)-(34,20))
+ Main.main (throwIO.hs:6:1-27)
+"Backtrace mechanisms [IPEBacktraceMech]:"
+Info Table Provenance Entries (IPE) backtrace:
+ ThrowTestLib.runThrowTest: ThrowTestLib.hs:26:18-30
+ ThrowTestLib.printBacktrace: ThrowTestLib.hs:(41,5)-(43,42)
+ ThrowTestLib.printBacktrace: ThrowTestLib.hs:42:48
+"Backtrace mechanisms [IPEBacktraceMech,CostCenterBacktraceMech,HasCallStackBacktraceMech]:"
+Info Table Provenance Entries (IPE) backtrace:
+ ThrowTestLib.runThrowTest: ThrowTestLib.hs:28:5-17
+ ThrowTestLib.printBacktrace: ThrowTestLib.hs:(41,5)-(43,42)
+ ThrowTestLib.printBacktrace: ThrowTestLib.hs:42:48
+Cost Centre backtrace:
+ ThrowTestLib.produceDeepStack.getDeepStackCase (ThrowTestLib.hs:(61,5)-(62,53))
+ ThrowTestLib.produceDeepStack (ThrowTestLib.hs:(51,1)-(62,53))
+ ThrowTestLib.printBacktrace (ThrowTestLib.hs:(37,1)-(44,9))
+ ThrowTestLib.runThrowTest (ThrowTestLib.hs:(18,1)-(34,20))
+ Main.main (throwIO.hs:6:1-27)
+HasCallStack backtrace:
+ CallStack (from HasCallStack):
+   collectHasCallStackBacktrace, called at libraries/base/GHC/Exception/Backtrace.hs:109:52 in base:GHC.Exception.Backtrace
+   collectBacktraces', called at libraries/base/GHC/Exception/Backtrace.hs:102:27 in base:GHC.Exception.Backtrace
+   collectBacktraces, called at libraries/base/GHC/IO.hs:239:7 in base:GHC.IO
+   throwIO, called at throwIO.hs:6:21 in main:Main
diff --git a/libraries/base/tests/GHC/IO/throwIOWithCallStack.hs b/libraries/base/tests/GHC/IO/throwIOWithCallStack.hs
new file mode 100644
index 0000000000..8d68893154
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/throwIOWithCallStack.hs
@@ -0,0 +1,17 @@
+module Main where
+
+import Control.Exception
+import GHC.Exception
+import GHC.IO
+
+data CustomException = CustomException deriving (Show)
+
+instance Exception CustomException
+
+main :: IO ()
+main =
+  catch
+    (throwIOWithCallStack CustomException)
+    printBacktraces
+  where
+    printBacktraces = putStr . pprBacktraces
diff --git a/libraries/base/tests/GHC/IO/throwIOWithCallStack.stdout b/libraries/base/tests/GHC/IO/throwIOWithCallStack.stdout
new file mode 100644
index 0000000000..7afa6ab7c6
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/throwIOWithCallStack.stdout
@@ -0,0 +1,4 @@
+HasCallStack backtrace:
+ CallStack (from HasCallStack):
+   collectHasCallStackBacktrace, called at libraries/base/GHC/IO.hs:253:34 in base:GHC.IO
+   throwIOWithCallStack, called at throwIOWithCallStack.hs:14:6 in main:Main
\ No newline at end of file
diff --git a/libraries/base/tests/GHC/IO/throwIOWithCallStack_Windows.hs b/libraries/base/tests/GHC/IO/throwIOWithCallStack_Windows.hs
new file mode 100644
index 0000000000..8d68893154
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/throwIOWithCallStack_Windows.hs
@@ -0,0 +1,17 @@
+module Main where
+
+import Control.Exception
+import GHC.Exception
+import GHC.IO
+
+data CustomException = CustomException deriving (Show)
+
+instance Exception CustomException
+
+main :: IO ()
+main =
+  catch
+    (throwIOWithCallStack CustomException)
+    printBacktraces
+  where
+    printBacktraces = putStr . pprBacktraces
diff --git a/libraries/base/tests/GHC/IO/throwIOWithCallStack_Windows.stdout b/libraries/base/tests/GHC/IO/throwIOWithCallStack_Windows.stdout
new file mode 100644
index 0000000000..e8784b4928
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/throwIOWithCallStack_Windows.stdout
@@ -0,0 +1,4 @@
+HasCallStack backtrace:
+ CallStack (from HasCallStack):
+   collectHasCallStackBacktrace, called at libraries/base/GHC/IO.hs:253:34 in base:GHC.IO
+   throwIOWithCallStack, called at throwIOWithCallStack_Windows.hs:<line>:<column> in <package-id>:Main
diff --git a/libraries/base/tests/GHC/IO/throwIOWithCostCenterStack.hs b/libraries/base/tests/GHC/IO/throwIOWithCostCenterStack.hs
new file mode 100644
index 0000000000..045c20bf58
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/throwIOWithCostCenterStack.hs
@@ -0,0 +1,17 @@
+module Main where
+
+import Control.Exception
+import GHC.Exception
+import GHC.IO
+
+data CustomException = CustomException deriving (Show)
+
+instance Exception CustomException
+
+main :: IO ()
+main =
+  catch
+    (throwIOWithCostCenterStack CustomException)
+    printBacktraces
+  where
+    printBacktraces = putStr . pprBacktraces
diff --git a/libraries/base/tests/GHC/IO/throwIOWithCostCenterStack.stdout b/libraries/base/tests/GHC/IO/throwIOWithCostCenterStack.stdout
new file mode 100644
index 0000000000..dd32592927
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/throwIOWithCostCenterStack.stdout
@@ -0,0 +1,2 @@
+Cost Centre backtrace:
+ Main.main (throwIOWithCostCenterStack.hs:(12,1)-(17,44))
\ No newline at end of file
diff --git a/libraries/base/tests/GHC/IO/throwIOWithIPEStack.hs b/libraries/base/tests/GHC/IO/throwIOWithIPEStack.hs
new file mode 100644
index 0000000000..b3bccdc62a
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/throwIOWithIPEStack.hs
@@ -0,0 +1,29 @@
+module Main where
+
+import Control.Exception
+import GHC.Exception
+import GHC.IO
+import System.IO.Unsafe
+
+data CustomException = CustomException deriving (Show)
+
+instance Exception CustomException
+
+main :: IO ()
+main = do
+  catch
+    (throwExceptionInScrutinee 1 >> pure ())
+    printBacktraces
+  where
+    printBacktraces = putStr . pprBacktraces
+
+-- Force creation of Stg stack return frames for IPE based backtraces.
+throwExceptionInScrutinee :: Int -> IO Int
+throwExceptionInScrutinee deepness = case unsafePerformIO $ scrutinee deepness of
+  -- Due the the thrown exception, the cases below are never hit!
+  0 -> pure 42
+  i -> pure i
+  where
+    scrutinee :: Int -> IO Int
+    scrutinee 0 = throwIOWithIPEStack CustomException
+    scrutinee n = scrutinee $ n - 1
diff --git a/libraries/base/tests/GHC/IO/throwIOWithIPEStack.stdout b/libraries/base/tests/GHC/IO/throwIOWithIPEStack.stdout
new file mode 100644
index 0000000000..1d82d0ae37
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/throwIOWithIPEStack.stdout
@@ -0,0 +1,2 @@
+Info Table Provenance Entries (IPE) backtrace:
+ Main.throwExceptionInScrutinee: throwIOWithIPEStack.hs:22:43-57
\ No newline at end of file
diff --git a/libraries/base/tests/GHC/IO/throwIO_rethrowException.hs b/libraries/base/tests/GHC/IO/throwIO_rethrowException.hs
new file mode 100644
index 0000000000..b586adf281
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/throwIO_rethrowException.hs
@@ -0,0 +1,33 @@
+module Main where
+
+import Control.Exception
+import GHC.Exception
+import GHC.Exception.Backtrace
+import System.Exit
+
+data CustomException = CustomException deriving (Show)
+
+instance Exception CustomException
+
+-- When an exception is thrown more than one times, it keeps the first backtrace.
+-- This test shares almost all code with GHC/Exception/throw_rethrowException.hs.
+-- Unfortunately, the test function cannot be parameterized over the throw* function,
+-- because that would change the backtrace in an unsuable manner.
+main :: IO ()
+main = do
+  setDefaultBacktraceMechanisms [HasCallStackBacktraceMech]
+  catch
+    ( catch
+        -- Throw for the first time.
+        (throwIO CustomException)
+        -- Throw for the second time.
+        (\(e :: SomeExceptionWithLocation) -> throwIO e)
+    )
+    ( \(e :: SomeExceptionWithLocation) -> case e of
+        (SomeExceptionWithLocation _ bts) ->
+          case head bts of
+            -- Only print the most significant location; i.e. the location
+            -- where throw was called.
+            HasCallStackBacktrace cs -> print $ last $ getCallStack cs
+            _ -> exitFailure
+    )
diff --git a/libraries/base/tests/GHC/IO/throwIO_rethrowException.stdout b/libraries/base/tests/GHC/IO/throwIO_rethrowException.stdout
new file mode 100644
index 0000000000..52efb2c4a7
--- /dev/null
+++ b/libraries/base/tests/GHC/IO/throwIO_rethrowException.stdout
@@ -0,0 +1 @@
+("throwIO",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "throwIO_rethrowException.hs", srcLocStartLine = 22, srcLocStartCol = 10, srcLocEndLine = 22, srcLocEndCol = 17})
diff --git a/libraries/bytestring b/libraries/bytestring
-Subproject e84481a06ae4b50984469a79f2c1af4b2f02029
+Subproject 310cdb90c925c35f962df9c690bd35e20136da2
diff --git a/libraries/process b/libraries/process
-Subproject bcbbb902b5f6f9bbd433873b6ce097594ea8c75
+Subproject b14bac14e519c29f4cb786b9bbe4e7f3e41d42f
diff --git a/libraries/stm b/libraries/stm
-Subproject 3fbd061e76a76cf0ae5ccc66b29c14cdfc7dbc5
+Subproject 691abe5ed0449057c0fb0794f0f7fd75ae5faf4
diff --git a/libraries/unix b/libraries/unix
-Subproject c7a95042a77244756f5b6476bf7dcf7190bc9e3
+Subproject b4380b05e83fa5e6c9ebb9b292f5bf58b3505e9
diff --git a/testsuite/tests/ghci.debugger/scripts/T14690.stdout b/testsuite/tests/ghci.debugger/scripts/T14690.stdout
index 26524b7036..4ca48bdd87 100644
--- a/testsuite/tests/ghci.debugger/scripts/T14690.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/T14690.stdout
@@ -1,10 +1,16 @@
 Stopped in <exception thrown>, <unknown>
-_exception :: e = _
+_exception :: e = GHC.Exception.Type.SomeExceptionWithLocation
+                    (GHC.Exception.Type.SomeException
+                       (GHC.Exception.ErrorCallWithLocation ...))
+                    []
 :steplocal is not possible.
 Cannot determine current top-level binding after a break on error / exception.
 Use :stepmodule.
 Stopped in <exception thrown>, <unknown>
-_exception :: e = _
+_exception :: e = GHC.Exception.Type.SomeExceptionWithLocation
+                    (GHC.Exception.Type.SomeException
+                       (GHC.Exception.ErrorCallWithLocation ...))
+                    []
 :steplocal is not possible.
 Cannot determine current top-level binding after a break on error / exception.
 Use :stepmodule.
diff --git a/testsuite/tests/ghci.debugger/scripts/break011.stdout b/testsuite/tests/ghci.debugger/scripts/break011.stdout
index 2b3cdfd338..146ded0fea 100644
--- a/testsuite/tests/ghci.debugger/scripts/break011.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break011.stdout
@@ -19,35 +19,24 @@ Stopped at <unknown>
 _exception :: e
 already at the beginning of the history
 _exception = SomeExceptionWithLocation
-               (ErrorCallWithLocation
-                  "foo"
-                  "CallStack (from HasCallStack):
-  error, called at Test7.hs:2:18 in main:Main")
+               (SomeException
+                  (ErrorCallWithLocation
+                     "foo"
+                     "CallStack (from HasCallStack):
+  error, called at Test7.hs:2:18 in main:Main"))
                []
 _result :: a = _
 _exception :: SomeExceptionWithLocation = SomeExceptionWithLocation
-                                            (ErrorCallWithLocation
-                                               "foo"
-                                               "CallStack (from HasCallStack):
-  error, called at Test7.hs:2:18 in main:Main")
-                                            []
+                                            (SomeException (ErrorCallWithLocation ...)) []
 *** Exception: foo
 CallStack (from HasCallStack):
   error, called at Test7.hs:2:18 in main:Main
 Stopped in <exception thrown>, <unknown>
 _exception :: e = SomeExceptionWithLocation
-                    (ErrorCallWithLocation
-                       "foo"
-                       "CallStack (from HasCallStack):
-  error, called at Test7.hs:2:18 in main:Main")
-                    []
+                    (SomeException (ErrorCallWithLocation ...)) []
 Stopped in <exception thrown>, <unknown>
 _exception :: e = SomeExceptionWithLocation
-                    (ErrorCallWithLocation
-                       "foo"
-                       "CallStack (from HasCallStack):
-  error, called at Test7.hs:2:18 in main:Main")
-                    []
+                    (SomeException (ErrorCallWithLocation ...)) []
 *** Exception: foo
 CallStack (from HasCallStack):
   error, called at Test7.hs:2:18 in main:Main
diff --git a/testsuite/tests/ghci.debugger/scripts/break024.stdout b/testsuite/tests/ghci.debugger/scripts/break024.stdout
index 8f949411fb..032386638d 100644
--- a/testsuite/tests/ghci.debugger/scripts/break024.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break024.stdout
@@ -1,25 +1,30 @@
 Left user error (error)
 Stopped in <exception thrown>, <unknown>
-_exception :: e = _
+_exception :: e = SomeExceptionWithLocation
+                    (SomeException (GHC.IO.Exception.IOError ...)) []
 _exception = SomeExceptionWithLocation
-               (GHC.IO.Exception.IOError
-                  Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing)
+               (SomeException
+                  (GHC.IO.Exception.IOError
+                     Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing))
                []
 *** Exception: user error (error)
 Stopped in <exception thrown>, <unknown>
-_exception :: e = _
+_exception :: e = SomeExceptionWithLocation
+                    (SomeException (GHC.IO.Exception.IOError ...)) []
 _exception = SomeExceptionWithLocation
-               (GHC.IO.Exception.IOError
-                  Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing)
+               (SomeException
+                  (GHC.IO.Exception.IOError
+                     Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing))
                []
 Stopped in <exception thrown>, <unknown>
 _exception :: e = SomeExceptionWithLocation
-                    (GHC.IO.Exception.IOError Nothing GHC.IO.Exception.UserError ....)
-                    []
+                    (SomeException (GHC.IO.Exception.IOError ...)) []
 Stopped in <exception thrown>, <unknown>
-_exception :: e = _
+_exception :: e = SomeExceptionWithLocation
+                    (SomeException (GHC.IO.Exception.IOError ...)) []
 _exception = SomeExceptionWithLocation
-               (GHC.IO.Exception.IOError
-                  Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing)
+               (SomeException
+                  (GHC.IO.Exception.IOError
+                     Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing))
                []
 Left user error (error)
diff --git a/utils/haddock b/utils/haddock
-Subproject 02653b83b36b53246bc72a9427af86806ccef79
+Subproject d57a43cfa5345f9792b516db74bbd0a1e80412c