compiler/GHC/Cmm/CLabel.hs

@@ -299,6 +299,7 @@ data ModuleLabelKind
     | MLK_InitializerArray
     | MLK_Finalizer String
     | MLK_FinalizerArray
+    | MLK_IPEBuffer
     deriving (Eq, Ord)
 
 instance Outputable ModuleLabelKind where
@@ -306,6 +307,7 @@ instance Outputable ModuleLabelKind where
     ppr (MLK_Initializer s)  = text ("init__" ++ s)
     ppr MLK_FinalizerArray   = text "fini_arr"
     ppr (MLK_Finalizer s)    = text ("fini__" ++ s)
+    ppr MLK_IPEBuffer        = text "ipe_buf"
 
 isIdLabel :: CLabel -> Bool
 isIdLabel IdLabel{} = True
@@ -830,10 +832,10 @@ instance OutputableP Platform InfoProvEnt where
 -- Constructing Cost Center Labels
 mkCCLabel  :: CostCentre      -> CLabel
 mkCCSLabel :: CostCentreStack -> CLabel
-mkIPELabel :: InfoProvEnt -> CLabel
+mkIPELabel :: Module          -> CLabel
 mkCCLabel           cc          = CC_Label cc
 mkCCSLabel          ccs         = CCS_Label ccs
-mkIPELabel          ipe         = IPE_Label ipe
+mkIPELabel          mod         = ModuleLabel mod MLK_IPEBuffer
 
 mkRtsApFastLabel :: FastString -> CLabel
 mkRtsApFastLabel str = RtsLabel (RtsApFast (NonDetFastString str))
@@ -1011,6 +1013,7 @@ modLabelNeedsCDecl :: ModuleLabelKind -> Bool
 -- Code for finalizers and initializers are emitted in stub objects
 modLabelNeedsCDecl (MLK_Initializer _)  = True
 modLabelNeedsCDecl (MLK_Finalizer   _)  = True
+modLabelNeedsCDecl MLK_IPEBuffer        = True
 -- The finalizer and initializer arrays are emitted in the code of the module
 modLabelNeedsCDecl MLK_InitializerArray = False
 modLabelNeedsCDecl MLK_FinalizerArray   = False
@@ -1208,6 +1211,7 @@ moduleLabelKindType kind =
     MLK_InitializerArray -> DataLabel
     MLK_Finalizer _      -> CodeLabel
     MLK_FinalizerArray   -> DataLabel
+    MLK_IPEBuffer        -> DataLabel
 
 idInfoLabelType :: IdLabelInfo -> CLabelType
 idInfoLabelType info =

compiler/GHC/Cmm/Parser.y

@@ -224,6 +224,7 @@ import GHC.StgToCmm.Layout     hiding (ArgRep(..))
 import GHC.StgToCmm.Ticky
 import GHC.StgToCmm.Prof
 import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame )
+import GHC.StgToCmm.InfoTableProv
 
 import GHC.Cmm.Opt
 import GHC.Cmm.Graph
@@ -1518,9 +1519,8 @@ parseCmmFile cmmpConfig this_mod home_unit filename = do
         let fcode = do
               ((), cmm) <- getCmm $ unEC code "global" (initEnv (pdProfile pdConfig)) [] >> return ()
               -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)
-              let used_info = map (cmmInfoTableToInfoProvEnt this_mod)
-                                              (mapMaybe topInfoTable cmm)
-              ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info
+              let used_info = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm)
+              ((), cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info
               return (cmm ++ cmm2, used_info)
             (cmm, _) = runC (cmmpStgToCmmConfig cmmpConfig) fstate st fcode
             (warnings,errors) = getPsMessages pst

compiler/GHC/Driver/CodeOutput.hs

@@ -368,24 +368,17 @@ ipInitCode
   :: Bool            -- is Opt_InfoTableMap enabled or not
   -> Platform
   -> Module
-  -> [InfoProvEnt]
   -> CStub
-ipInitCode do_info_table platform this_mod ents
+ipInitCode do_info_table platform this_mod
   | not do_info_table = mempty
-  | otherwise = initializerCStub platform fn_nm decls body
+  | otherwise = initializerCStub platform fn_nm ipe_buffer_decl body
  where
    fn_nm = mkInitializerStubLabel this_mod "ip_init"
-   decls = vcat
-        $  map emit_ipe_decl ents
-        ++ [emit_ipe_list ents]
-   body = text "registerInfoProvList" <> parens local_ipe_list_label <> semi
-   emit_ipe_decl ipe =
-       text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"
-     where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)
-   local_ipe_list_label = text "local_ipe_" <> ppr this_mod
-   emit_ipe_list ipes =
-      text "static InfoProvEnt *" <> local_ipe_list_label <> text "[] ="
-      <+> braces (vcat $ [ pprCLabel platform CStyle (mkIPELabel ipe) <> comma
-                         | ipe <- ipes
-                         ] ++ [text "NULL"])
-      <> semi
+
+   body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi
+
+   ipe_buffer_label = pprCLabel platform CStyle (mkIPELabel this_mod)
+
+   ipe_buffer_decl =
+       text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";"
+

compiler/GHC/Driver/Main.hs

@@ -1830,7 +1830,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
         mod_name = mkModuleName $ "Cmm$" ++ original_filename
         cmm_mod = mkHomeModule home_unit mod_name
         cmmpConfig = initCmmParserConfig dflags
-    (cmm, ents) <- ioMsgMaybe
+    (cmm, _ents) <- ioMsgMaybe
                $ do
                   (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
                                        $ parseCmmFile cmmpConfig cmm_mod home_unit filename
@@ -1857,7 +1857,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
           Just h  -> h           dflags Nothing (Stream.yield cmmgroup)
 
         let foreign_stubs _ =
-              let ip_init   = ipInitCode do_info_table platform cmm_mod ents
+              let ip_init = ipInitCode do_info_table platform cmm_mod
               in NoStubs `appendStubC` ip_init
 
         (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)

compiler/GHC/StgToCmm/InfoTableProv.hs

+module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where
+
+import GHC.Prelude
+import GHC.Platform
+import GHC.Unit.Module
+import GHC.Utils.Outputable
+import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile)
+import GHC.Data.FastString (unpackFS)
+
+import GHC.Cmm.CLabel
+import GHC.Cmm.Expr
+import GHC.Cmm.Utils
+import GHC.StgToCmm.Config
+import GHC.StgToCmm.Lit (newByteStringCLit)
+import GHC.StgToCmm.Monad
+import GHC.StgToCmm.Utils
+
+import GHC.Data.ShortText (ShortText)
+import qualified GHC.Data.ShortText as ST
+
+import qualified Data.Map.Strict as M
+import Control.Monad.Trans.State.Strict
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as BSB
+import qualified Data.ByteString.Lazy as BSL
+
+emitIpeBufferListNode :: Module
+                      -> [InfoProvEnt]
+                      -> FCode ()
+emitIpeBufferListNode this_mod ents = do
+    cfg <- getStgToCmmConfig
+    let ctx      = stgToCmmContext  cfg
+        platform = stgToCmmPlatform cfg
+
+    let (cg_ipes, strtab) = flip runState emptyStringTable $ do
+            module_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr this_mod)
+            mapM (toCgIPE platform ctx module_name) ents
+
+    let -- Emit the fields of an IpeBufferEntry struct.
+        toIpeBufferEntry :: CgInfoProvEnt -> [CmmLit]
+        toIpeBufferEntry cg_ipe =
+            [ CmmLabel (ipeInfoTablePtr cg_ipe)
+            , strtab_offset (ipeTableName cg_ipe)
+            , strtab_offset (ipeClosureDesc cg_ipe)
+            , strtab_offset (ipeTypeDesc cg_ipe)
+            , strtab_offset (ipeLabel cg_ipe)
+            , strtab_offset (ipeModuleName cg_ipe)
+            , strtab_offset (ipeSrcFile cg_ipe)
+            , strtab_offset (ipeSrcSpan cg_ipe)
+            , int32 0
+            ]
+
+        int n = mkIntCLit platform n
+        int32 n = CmmInt n W32
+        strtab_offset (StrTabOffset n) = int32 (fromIntegral n)
+
+    strings <- newByteStringCLit (getStringTableStrings strtab)
+    let lits = [ zeroCLit platform     -- 'next' field
+               , strings               -- 'strings' field
+               , int $ length cg_ipes  -- 'count' field
+               ] ++ concatMap toIpeBufferEntry cg_ipes
+    emitDataLits (mkIPELabel this_mod) lits
+
+toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt
+toCgIPE platform ctx module_name ipe = do
+    table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform CStyle (infoTablePtr ipe))
+    closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe)
+    type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe
+    let label_str = maybe "" snd (infoTableProv ipe)
+    let (src_loc_file, src_loc_span) =
+            case infoTableProv ipe of
+              Nothing -> ("", "")
+              Just (span, _) ->
+                  let file = unpackFS $ srcSpanFile span
+                      coords = renderWithContext ctx (pprUserRealSpan False span)
+                  in (file, coords)
+    label <- lookupStringTable $ ST.pack label_str
+    src_file <- lookupStringTable $ ST.pack src_loc_file
+    src_span <- lookupStringTable $ ST.pack src_loc_span
+    return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe
+                           , ipeTableName = table_name
+                           , ipeClosureDesc = closure_desc
+                           , ipeTypeDesc = type_desc
+                           , ipeLabel = label
+                           , ipeModuleName = module_name
+                           , ipeSrcFile = src_file
+                           , ipeSrcSpan = src_span
+                           }
+
+data CgInfoProvEnt = CgInfoProvEnt
+                               { ipeInfoTablePtr :: !CLabel
+                               , ipeTableName :: !StrTabOffset
+                               , ipeClosureDesc :: !StrTabOffset
+                               , ipeTypeDesc :: !StrTabOffset
+                               , ipeLabel :: !StrTabOffset
+                               , ipeModuleName :: !StrTabOffset
+                               , ipeSrcFile :: !StrTabOffset
+                               , ipeSrcSpan :: !StrTabOffset
+                               }
+
+data StringTable = StringTable { stStrings :: DList ShortText
+                               , stLength :: !Int
+                               , stLookup :: !(M.Map ShortText StrTabOffset)
+                               }
+
+newtype StrTabOffset = StrTabOffset Int
+
+emptyStringTable :: StringTable
+emptyStringTable =
+    StringTable { stStrings = emptyDList
+                , stLength = 0
+                , stLookup = M.empty
+                }
+
+getStringTableStrings :: StringTable -> BS.ByteString
+getStringTableStrings st =
+    BSL.toStrict $ BSB.toLazyByteString
+    $ foldMap f $ dlistToList (stStrings st)
+  where
+    f x = BSB.shortByteString (ST.contents x) `mappend` BSB.word8 0
+
+lookupStringTable :: ShortText -> State StringTable StrTabOffset
+lookupStringTable str = state $ \st ->
+    case M.lookup str (stLookup st) of
+      Just off -> (off, st)
+      Nothing ->
+          let !st' = st { stStrings = stStrings st `snoc` str
+                        , stLength  = stLength st + ST.byteLength str + 1
+                        , stLookup  = M.insert str res (stLookup st)
+                        }
+              res = StrTabOffset (stLength st)
+          in (res, st')
+
+newtype DList a = DList ([a] -> [a])
+
+emptyDList :: DList a
+emptyDList = DList id
+
+snoc :: DList a -> a -> DList a
+snoc (DList f) x = DList (f . (x:))
+
+dlistToList :: DList a -> [a]
+dlistToList (DList f) = f []

compiler/GHC/StgToCmm/Prof.hs

@@ -11,7 +11,7 @@ module GHC.StgToCmm.Prof (
         mkCCostCentre, mkCCostCentreStack,
 
         -- infoTablePRov
-        initInfoTableProv, emitInfoTableProv,
+        initInfoTableProv,
 
         -- Cost-centre Profiling
         dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
@@ -32,6 +32,7 @@ import GHC.Platform
 import GHC.Platform.Profile
 import GHC.StgToCmm.Closure
 import GHC.StgToCmm.Config
+import GHC.StgToCmm.InfoTableProv
 import GHC.StgToCmm.Utils
 import GHC.StgToCmm.Monad
 import GHC.StgToCmm.Lit
@@ -55,7 +56,6 @@ import GHC.Utils.Encoding
 
 import Control.Monad
 import Data.Char       (ord)
-import Data.Bifunctor  (first)
 import GHC.Utils.Monad (whenM)
 
 -----------------------------------------------------------------------------
@@ -274,9 +274,8 @@ sizeof_ccs_words platform
   where
    (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform
 
-
+-- | Emit info-table provenance declarations
 initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> FCode CStub
--- Emit the declarations
 initInfoTableProv infos itmap
   = do
        cfg <- getStgToCmmConfig
@@ -284,42 +283,16 @@ initInfoTableProv infos itmap
            info_table = stgToCmmInfoTableMap cfg
            platform   = stgToCmmPlatform     cfg
            this_mod   = stgToCmmThisModule   cfg
-       -- Output the actual IPE data
-       mapM_ emitInfoTableProv ents
-       -- Create the C stub which initialises the IPE map
-       return (ipInitCode info_table platform this_mod ents)
-
---- Info Table Prov stuff
-emitInfoTableProv :: InfoProvEnt  -> FCode ()
-emitInfoTableProv ip = do
-  { cfg <- getStgToCmmConfig
-  ; let mod      = infoProvModule ip
-        ctx      = stgToCmmContext  cfg
-        platform = stgToCmmPlatform cfg
-  ; let (src, label) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ip)
-        mk_string    = newByteStringCLit . utf8EncodeByteString
-  ; label <- mk_string label
-  ; modl  <- newByteStringCLit (bytesFS $ moduleNameFS
-                                        $ moduleName mod)
-
-  ; ty_string  <- mk_string (infoTableType ip)
-  ; loc        <- mk_string src
-  ; table_name <- mk_string (renderWithContext ctx
-                             (pprCLabel platform CStyle (infoTablePtr ip)))
-  ; closure_type <- mk_string (renderWithContext ctx
-                               (text $ show $ infoProvEntClosureType ip))
-  ; let
-     lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer
-              table_name,     -- char *table_name
-              closure_type,   -- char *closure_desc -- Filled in from the InfoTable
-              ty_string,      -- char *ty_string
-              label,          -- char *label,
-              modl,           -- char *module,
-              loc,            -- char *srcloc,
-              zero platform   -- struct _InfoProvEnt *link
-            ]
-  ; emitDataLits (mkIPELabel ip) lits
-  }
+
+       case ents of
+         [] -> return mempty
+         _  -> do
+           -- Emit IPE buffer
+           emitIpeBufferListNode this_mod ents
+
+           -- Create the C stub which initialises the IPE map
+           return (ipInitCode info_table platform this_mod)
+
 -- ---------------------------------------------------------------------------
 -- Set the current cost centre stack
 

compiler/ghc.cabal.in

@@ -615,6 +615,7 @@ Library
         GHC.StgToCmm.Foreign
         GHC.StgToCmm.Heap
         GHC.StgToCmm.Hpc
+        GHC.StgToCmm.InfoTableProv
         GHC.StgToCmm.Layout
         GHC.StgToCmm.Lit
         GHC.StgToCmm.Monad

libraries/base/Foreign/C/String.hs

@@ -110,20 +110,11 @@ import GHC.Base
 
 import {-# SOURCE #-} GHC.IO.Encoding
 import qualified GHC.Foreign as GHC
+import GHC.Foreign (CString, CStringLen)
 
 -----------------------------------------------------------------------------
 -- Strings
 
--- representation of strings in C
--- ------------------------------
-
--- | A C string is a reference to an array of C characters terminated by NUL.
-type CString    = Ptr CChar
-
--- | A string with explicit length information in bytes instead of a
--- terminating NUL (allowing NUL characters in the middle of the string).
-type CStringLen = (Ptr CChar, Int)
-
 -- exported functions
 -- ------------------
 --

libraries/base/GHC/Conc/Sync.hs

@@ -121,11 +121,8 @@ import GHC.IORef
 import GHC.MVar
 import GHC.Real         ( fromIntegral )
 import GHC.Show         ( Show(..), showParen, showString )
-import GHC.Stable       ( StablePtr(..) )
 import GHC.Weak
 
-import Unsafe.Coerce    ( unsafeCoerce# )
-
 infixr 0 `par`, `pseq`
 
 -----------------------------------------------------------------------------
@@ -663,20 +660,6 @@ mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
       (# s1, w #) -> (# s1, Weak w #)
 
 
-data PrimMVar
-
--- | Make a 'StablePtr' that can be passed to the C function
--- @hs_try_putmvar()@.  The RTS wants a 'StablePtr' to the
--- underlying 'MVar#', but a 'StablePtr#' can only refer to
--- lifted types, so we have to cheat by coercing.
-newStablePtrPrimMVar :: MVar a -> IO (StablePtr PrimMVar)
-newStablePtrPrimMVar (MVar m) = IO $ \s0 ->
-  case makeStablePtr# (unsafeCoerce# m :: PrimMVar) s0 of
-    -- Coerce unlifted  m :: MVar# RealWorld a
-    --     to lifted    PrimMVar
-    -- apparently because mkStablePtr is not representation-polymorphic
-    (# s1, sp #) -> (# s1, StablePtr sp #)
-
 -----------------------------------------------------------------------------
 -- Transactional heap operations
 -----------------------------------------------------------------------------

libraries/base/GHC/Exception.hs

@@ -2,10 +2,12 @@
 {-# LANGUAGE NoImplicitPrelude
            , ExistentialQuantification
            , MagicHash
-           , RecordWildCards
            , PatternSynonyms
   #-}
-{-# LANGUAGE DataKinds, PolyKinds #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
 {-# OPTIONS_HADDOCK not-home #-}
 
 -----------------------------------------------------------------------------
@@ -28,7 +30,8 @@ module GHC.Exception
        , ErrorCall(..,ErrorCall)
        , errorCallException
        , errorCallWithCallStackException
-         -- re-export CallStack and SrcLoc from GHC.Types
+
+         -- * Re-exports from GHC.Types
        , CallStack, fromCallSiteList, getCallStack, prettyCallStack
        , prettyCallStackLines, showCCSStack
        , SrcLoc(..), prettySrcLoc
@@ -40,6 +43,9 @@ import GHC.Stack.Types
 import GHC.OldList
 import GHC.IO.Unsafe
 import {-# SOURCE #-} GHC.Stack.CCS
+import {-# SOURCE #-} GHC.Stack (prettyCallStackLines, prettyCallStack, prettySrcLoc)
+import GHC.Exception.Backtrace
+import GHC.Exception.Context
 import GHC.Exception.Type
 
 -- | Throw an exception.  Exceptions may be thrown from purely
@@ -48,8 +54,10 @@ import GHC.Exception.Type
 -- 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.
-         Exception e => e -> a
-throw e = raise# (toException e)
+         (?callStack :: CallStack, Exception e) => e -> a
+throw e =
+    let !context = unsafePerformIO collectBacktraces
+    in raise# (toExceptionWithContext e context)
 
 -- | This is thrown when the user calls 'error'. The first @String@ is the
 -- argument given to 'error', second @String@ is the location.
@@ -89,31 +97,3 @@ showCCSStack :: [String] -> [String]
 showCCSStack [] = []
 showCCSStack stk = "CallStack (from -prof):" : map ("  " ++) (reverse stk)
 
--- prettySrcLoc and prettyCallStack are defined here to avoid hs-boot
--- files. See Note [Definition of CallStack]
-
--- | Pretty print a 'SrcLoc'.
---
--- @since 4.9.0.0
-prettySrcLoc :: SrcLoc -> String
-prettySrcLoc SrcLoc {..}
-  = foldr (++) ""
-      [ srcLocFile, ":"
-      , show srcLocStartLine, ":"
-      , show srcLocStartCol, " in "
-      , srcLocPackage, ":", srcLocModule
-      ]
-
--- | Pretty print a 'CallStack'.
---
--- @since 4.9.0.0
-prettyCallStack :: CallStack -> String
-prettyCallStack = intercalate "\n" . prettyCallStackLines
-
-prettyCallStackLines :: CallStack -> [String]
-prettyCallStackLines cs = case getCallStack cs of
-  []  -> []
-  stk -> "CallStack (from HasCallStack):"
-       : map (("  " ++) . prettyCallSite) stk
-  where
-    prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc

libraries/base/GHC/Exception/Backtrace.hs

+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module GHC.Exception.Backtrace
+    ( BacktraceMechanism(..)
+    , collectBacktraces
+    , collectBacktrace
+    ) where
+
+import GHC.Base
+import Data.OldList
+import GHC.Show (Show)
+import GHC.Exception.Context
+import GHC.Stack.Types (HasCallStack, CallStack)
+import {-# SOURCE #-} qualified GHC.Stack as CallStack
+import {-# SOURCE #-} qualified GHC.ExecutionStack as ExecStack
+import {-# SOURCE #-} qualified GHC.Stack.CloneStack as CloneStack
+import {-# SOURCE #-} qualified GHC.Stack.CCS as CCS
+
+-- | How to collect a backtrace when an exception is thrown.
+data BacktraceMechanism
+  = -- | collect a cost center stacktrace (only available when built with profiling)
+    CostCentreBacktraceMech
+  | -- | use execution stack unwinding with given limit
+    ExecutionStackBacktraceMech
+  | -- | collect backtraces from Info Table Provenance Entries
+    IPEBacktraceMech
+  | -- | use 'HasCallStack'
+    HasCallStackBacktraceMech
+  deriving (Eq, Show)
+
+collectBacktraces :: HasCallStack => IO ExceptionContext
+collectBacktraces = do
+    mconcat `fmap` mapM collect
+        [ CostCentreBacktraceMech
+        , ExecutionStackBacktraceMech
+        , IPEBacktraceMech
+        , HasCallStackBacktraceMech
+        ]
+  where
+    collect mech
+      | True = collectBacktrace mech -- FIXME
+      -- | otherwise = return mempty
+
+data CostCentreBacktrace = CostCentreBacktrace [String]
+
+instance ExceptionAnnotation CostCentreBacktrace where
+    displayExceptionAnnotation (CostCentreBacktrace strs) = CCS.renderStack strs
+
+data ExecutionBacktrace = ExecutionBacktrace String
+
+instance ExceptionAnnotation ExecutionBacktrace where
+    displayExceptionAnnotation (ExecutionBacktrace str) =
+        "Native stack backtrace:\n" ++ str
+
+data HasCallStackBacktrace = HasCallStackBacktrace CallStack
+
+instance ExceptionAnnotation HasCallStackBacktrace where
+    displayExceptionAnnotation (HasCallStackBacktrace cs) =
+        "HasCallStack backtrace:\n" ++ CallStack.prettyCallStack cs
+
+data InfoProvBacktrace = InfoProvBacktrace [CloneStack.StackEntry]
+
+instance ExceptionAnnotation InfoProvBacktrace where
+    displayExceptionAnnotation (InfoProvBacktrace stack) =
+        "Info table provenance backtrace:\n" ++
+        intercalate "\n" (map ("    "++) $ map CloneStack.prettyStackEntry stack)
+
+collectBacktrace :: (?callStack :: CallStack) => BacktraceMechanism -> IO ExceptionContext
+collectBacktrace CostCentreBacktraceMech = do
+    strs <- CCS.currentCallStack
+    case strs of
+      [] -> return emptyExceptionContext
+      _  -> pure $ mkExceptionContext (CostCentreBacktrace strs)
+
+collectBacktrace ExecutionStackBacktraceMech = do
+    mst <- ExecStack.showStackTrace
+    case mst of
+      Nothing -> return emptyExceptionContext
+      Just st -> return $ mkExceptionContext (ExecutionBacktrace st)
+
+collectBacktrace IPEBacktraceMech = do
+    stack <- CloneStack.cloneMyStack
+    stackEntries <- CloneStack.decode stack
+    return $ mkExceptionContext (InfoProvBacktrace stackEntries)
+
+collectBacktrace HasCallStackBacktraceMech =
+    return $ mkExceptionContext (HasCallStackBacktrace ?callStack)
+

libraries/base/GHC/Exception/Backtrace.hs-boot

+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.Exception.Backtrace where
+
+import GHC.Base (IO)
+import GHC.Exception.Context (ExceptionContext)
+import GHC.Stack.Types (HasCallStack)
+
+data BacktraceMechanism
+
+collectBacktraces :: HasCallStack => IO ExceptionContext

libraries/base/GHC/Exception/Context.hs

+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# OPTIONS_HADDOCK not-home #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.Exception.Context
+-- Copyright   :  (c) The University of Glasgow, 1998-2002
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC extensions)
+--
+-- Exception context type.
+--
+-----------------------------------------------------------------------------
+
+module GHC.Exception.Context
+    ( -- * Exception context
+      ExceptionContext(..)
+    , emptyExceptionContext
+    , mkExceptionContext
+    , mergeExceptionContexts
+      -- * Exception annotations
+    , SomeExceptionAnnotation(..)
+    , ExceptionAnnotation(..)
+    ) where
+
+import GHC.Base ((++), String, Semigroup(..), Monoid(..))
+import GHC.Show (Show(..))
+import Data.Typeable.Internal (Typeable)
+
+data ExceptionContext = ExceptionContext [SomeExceptionAnnotation]
+
+instance Semigroup ExceptionContext where
+    (<>) = mergeExceptionContexts
+
+instance Monoid ExceptionContext where
+    mempty = emptyExceptionContext
+
+emptyExceptionContext :: ExceptionContext
+emptyExceptionContext = ExceptionContext []
+
+mergeExceptionContexts :: ExceptionContext -> ExceptionContext -> ExceptionContext
+mergeExceptionContexts (ExceptionContext a) (ExceptionContext b) = ExceptionContext (a ++ b)
+
+mkExceptionContext :: ExceptionAnnotation a => a -> ExceptionContext
+mkExceptionContext x = ExceptionContext [SomeExceptionAnnotation x]
+
+data SomeExceptionAnnotation = forall a. ExceptionAnnotation a => SomeExceptionAnnotation a
+
+class Typeable a => ExceptionAnnotation a where
+    displayExceptionAnnotation :: a -> String
+
+    default displayExceptionAnnotation :: Show a => a -> String
+    displayExceptionAnnotation = show
+

libraries/base/GHC/Exception/Context.hs-boot

+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.Exception.Context where
+
+data ExceptionContext
+

libraries/base/GHC/Exception/Type.hs

 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE Trustworthy #-}
 
 {-# OPTIONS_HADDOCK not-home #-}
@@ -20,7 +21,14 @@
 
 module GHC.Exception.Type
        ( Exception(..)    -- Class
-       , SomeException(..), ArithException(..)
+       , SomeException(..)
+       , exceptionContext
+         -- * Exception context
+       , ExceptionContext(..)
+       , emptyExceptionContext
+       , mergeExceptionContexts
+         -- * Arithmetic exceptions
+       , ArithException(..)
        , divZeroException, overflowException, ratioZeroDenomException
        , underflowException
        ) where
@@ -30,13 +38,17 @@ import Data.Typeable (Typeable, cast)
    -- loop: Data.Typeable -> GHC.Err -> GHC.Exception
 import GHC.Base
 import GHC.Show
+import GHC.Exception.Context
 
 {- |
 The @SomeException@ 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 @SomeException@.
 -}
-data SomeException = forall e . Exception e => SomeException e
+data SomeException = forall e. (Exception e, ?exc_context :: ExceptionContext) => SomeException e
+
+exceptionContext :: SomeException -> ExceptionContext
+exceptionContext (SomeException _) = ?exc_context
 
 -- | @since 3.0
 instance Show SomeException where
@@ -129,10 +141,13 @@ Caught MismatchedParentheses
 
 -}
 class (Typeable e, Show e) => Exception e where
-    toException   :: e -> SomeException
+    toException            :: e -> SomeException
+    toExceptionWithContext :: e -> ExceptionContext -> SomeException
     fromException :: SomeException -> Maybe e
 
-    toException = SomeException
+    toException e = toExceptionWithContext e emptyExceptionContext
+    toExceptionWithContext e ctxt = SomeException e
+      where ?exc_context = ctxt
     fromException (SomeException e) = cast e
 
     -- | Render this exception value in a human-friendly manner.
@@ -146,8 +161,18 @@ class (Typeable e, Show e) => Exception e where
 -- | @since 3.0
 instance Exception SomeException where
     toException se = se
+    toExceptionWithContext se@(SomeException e) ctxt =
+        SomeException e
+      where ?exc_context = ctxt <> exceptionContext se
     fromException = Just
-    displayException (SomeException e) = displayException e
+    displayException (SomeException e) =
+        displayException e ++ "\n" ++ displayContext ?exc_context
+
+displayContext :: ExceptionContext -> String
+displayContext (ExceptionContext anns0) = go anns0
+  where
+    go (SomeExceptionAnnotation ann : anns) = displayExceptionAnnotation ann ++ "\n" ++ go anns
+    go [] = "\n"
 
 -- |Arithmetic exceptions.
 data ArithException

libraries/base/GHC/ExecutionStack.hs

+{-# LANGUAGE NoImplicitPrelude #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.ExecutionStack
@@ -36,7 +38,7 @@ module GHC.ExecutionStack (
   , showStackTrace
   ) where
 
-import Control.Monad (join)
+import GHC.Base
 import GHC.ExecutionStack.Internal
 
 -- | Get a trace of the current execution stack state.

libraries/base/GHC/ExecutionStack.hs-boot

+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.ExecutionStack where
+
+import GHC.Base
+
+showStackTrace :: IO (Maybe String)
+

libraries/base/GHC/ExecutionStack/Internal.hsc

@@ -17,6 +17,7 @@
 #include "HsBaseConfig.h"
 #include "rts/Libdw.h"
 
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE MultiWayIf #-}
 
 module GHC.ExecutionStack.Internal (
@@ -31,7 +32,13 @@ module GHC.ExecutionStack.Internal (
   , invalidateDebugCache
   ) where
 
-import Control.Monad (join)
+import GHC.Base
+import GHC.Show
+import GHC.List (reverse, null)
+import GHC.Num ((-))
+import GHC.Real (fromIntegral)
+import Data.Maybe
+import Data.Functor ((<$>))
 import Data.Word
 import Foreign.C.Types
 import Foreign.C.String (peekCString, CString)

libraries/base/GHC/Foreign.hs

@@ -19,6 +19,7 @@
 
 module GHC.Foreign (
     -- * C strings with a configurable encoding
+    CString, CStringLen,
 
     -- conversion of C strings into Haskell strings
     --
@@ -74,8 +75,11 @@ putDebugMsg | c_DEBUG_DUMP = debugLn
             | otherwise    = const (return ())
 
 
--- These definitions are identical to those in Foreign.C.String, but copied in here to avoid a cycle:
+-- | A C string is a reference to an array of C characters terminated by NUL.
 type CString    = Ptr CChar
+
+-- | A string with explicit length information in bytes instead of a
+-- terminating NUL (allowing NUL characters in the middle of the string).
 type CStringLen = (Ptr CChar, Int)
 
 -- exported functions

libraries/base/GHC/IO.hs

@@ -47,6 +47,8 @@ import GHC.ST
 import GHC.Exception
 import GHC.Show
 import GHC.IO.Unsafe
+import GHC.Stack.Types ( HasCallStack )
+import GHC.Exception.Backtrace ( collectBacktraces )
 import Unsafe.Coerce ( unsafeCoerce )
 
 import {-# SOURCE #-} GHC.IO.Exception ( userError, IOError )
@@ -235,8 +237,10 @@ mplusIO m n = m `catchException` \ (_ :: IOError) -> n
 -- for a more technical introduction to how GHC optimises around precise vs.
 -- imprecise exceptions.
 --
-throwIO :: Exception e => e -> IO a
-throwIO e = IO (raiseIO# (toException e))
+throwIO :: (HasCallStack, Exception e) => e -> IO a
+throwIO e = do
+    ctxt <- collectBacktraces
+    IO (raiseIO# (toExceptionWithContext e ctxt))
 
 -- -----------------------------------------------------------------------------
 -- Controlling asynchronous exception delivery