[Git][ghc/ghc][wip/exception-context] 12 commits: Separate IPE source file from span
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri Aug 19 15:20:35 UTC 2022
Ben Gamari pushed to branch wip/exception-context at Glasgow Haskell Compiler / GHC
Commits:
2f935f8d by Ben Gamari at 2022-08-19T11:19:44-04:00
Separate IPE source file from span
The source file name can very often be shared across many IPE entries
whereas the source coordinates are generally unique. Separate the two to
exploit sharing of the former.
- - - - -
6d1864b1 by Ben Gamari at 2022-08-19T11:20:09-04:00
base: Move CString, CStringLen to GHC.Foreign
- - - - -
f6b550ba by Ben Gamari at 2022-08-19T11:20:09-04:00
base: Move PrimMVar to GHC.MVar
- - - - -
ce764064 by Ben Gamari at 2022-08-19T11:20:09-04:00
base: Clean up imports of GHC.ExecutionStack
- - - - -
d35787ee by Ben Gamari at 2022-08-19T11:20:10-04:00
base: Clean up imports of GHC.Stack.CloneStack
- - - - -
1358b1cc by Ben Gamari at 2022-08-19T11:20:10-04:00
base: Introduce exception context
- - - - -
a7d2d12c by Ben Gamari at 2022-08-19T11:20:10-04:00
base: Collect backtraces in GHC.IO.throwIO
- - - - -
24d22b6a by Ben Gamari at 2022-08-19T11:20:10-04:00
base: Collect backtraces in GHC.Exception.throw
- - - - -
b41ebaa3 by Ben Gamari at 2022-08-19T11:20:10-04:00
Pretty IPE
- - - - -
aa5462fe by Ben Gamari at 2022-08-19T11:20:10-04:00
base: Move prettyCallStack to GHC.Stack
- - - - -
205bcf0e by Ben Gamari at 2022-08-19T11:20:10-04:00
Fix
- - - - -
b5d9acb1 by Ben Gamari at 2022-08-19T11:20:10-04:00
Formatting
- - - - -
27 changed files:
- compiler/GHC/StgToCmm/InfoTableProv.hs
- libraries/base/Foreign/C/String.hs
- libraries/base/GHC/Conc/Sync.hs
- libraries/base/GHC/Exception.hs
- + libraries/base/GHC/Exception/Backtrace.hs
- + libraries/base/GHC/Exception/Backtrace.hs-boot
- + libraries/base/GHC/Exception/Context.hs
- + libraries/base/GHC/Exception/Context.hs-boot
- libraries/base/GHC/Exception/Type.hs
- libraries/base/GHC/ExecutionStack.hs
- + libraries/base/GHC/ExecutionStack.hs-boot
- libraries/base/GHC/ExecutionStack/Internal.hsc
- libraries/base/GHC/Foreign.hs
- libraries/base/GHC/IO.hs
- libraries/base/GHC/InfoProv.hsc
- libraries/base/GHC/MVar.hs
- libraries/base/GHC/Stack.hs
- libraries/base/GHC/Stack/CCS.hs-boot
- libraries/base/GHC/Stack/CloneStack.hs
- + libraries/base/GHC/Stack/CloneStack.hs-boot
- libraries/base/base.cabal
- rts/IPE.c
- rts/Trace.c
- rts/Trace.h
- rts/eventlog/EventLog.c
- rts/eventlog/EventLog.h
- rts/include/rts/IPE.h
Changes:
=====================================
compiler/GHC/StgToCmm/InfoTableProv.hs
=====================================
@@ -4,6 +4,8 @@ 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
@@ -44,7 +46,8 @@ emitIpeBufferListNode this_mod ents = do
, strtab_offset (ipeTypeDesc cg_ipe)
, strtab_offset (ipeLabel cg_ipe)
, strtab_offset (ipeModuleName cg_ipe)
- , strtab_offset (ipeSrcLoc cg_ipe)
+ , strtab_offset (ipeSrcFile cg_ipe)
+ , strtab_offset (ipeSrcSpan cg_ipe)
]
int n = mkIntCLit platform n
@@ -63,16 +66,26 @@ 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)
let (src_loc_str, label_str) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ipe)
label <- lookupStringTable $ ST.pack label_str
- src_loc <- lookupStringTable $ ST.pack src_loc_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
- , ipeSrcLoc = src_loc
+ , ipeSrcFile = src_file
+ , ipeSrcSpan = src_span
}
data CgInfoProvEnt = CgInfoProvEnt
@@ -82,7 +95,8 @@ data CgInfoProvEnt = CgInfoProvEnt
, ipeTypeDesc :: !StrTabOffset
, ipeLabel :: !StrTabOffset
, ipeModuleName :: !StrTabOffset
- , ipeSrcLoc :: !StrTabOffset
+ , ipeSrcFile :: !StrTabOffset
+ , ipeSrcSpan :: !StrTabOffset
}
data StringTable = StringTable { stStrings :: DList ShortText
=====================================
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
=====================================
@@ -0,0 +1,90 @@
+{-# 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
=====================================
@@ -0,0 +1,11 @@
+{-# 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
=====================================
@@ -0,0 +1,59 @@
+{-# 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 at 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
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.Exception.Context where
+
+data ExceptionContext
+
=====================================
libraries/base/GHC/Exception/Type.hs
=====================================
@@ -1,5 +1,6 @@
{-# 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 at .
-}
-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
=====================================
@@ -1,3 +1,5 @@
+{-# 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
=====================================
@@ -0,0 +1,8 @@
+{-# 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
=====================================
libraries/base/GHC/InfoProv.hsc
=====================================
@@ -20,6 +20,7 @@
module GHC.InfoProv
( InfoProv(..)
+ , ipLoc
, ipeProv
, whereFrom
-- * Internals
@@ -42,10 +43,15 @@ data InfoProv = InfoProv {
ipTyDesc :: String,
ipLabel :: String,
ipMod :: String,
- ipLoc :: String
+ ipSrcFile :: String,
+ ipSrcSpan :: String
} deriving (Eq, Show)
+
data InfoProvEnt
+ipLoc :: InfoProv -> String
+ipLoc ipe = ipSrcFile ipe ++ ":" ++ ipSrcSpan ipe
+
getIPE :: a -> IO (Ptr InfoProvEnt)
getIPE obj = IO $ \s ->
case whereFrom## obj s of
@@ -54,13 +60,14 @@ getIPE obj = IO $ \s ->
ipeProv :: Ptr InfoProvEnt -> Ptr InfoProv
ipeProv p = (#ptr InfoProvEnt, prov) p
-peekIpName, peekIpDesc, peekIpLabel, peekIpModule, peekIpSrcLoc, peekIpTyDesc :: Ptr InfoProv -> IO CString
-peekIpName p = (# peek InfoProv, table_name) p
-peekIpDesc p = (# peek InfoProv, closure_desc) p
-peekIpLabel p = (# peek InfoProv, label) p
-peekIpModule p = (# peek InfoProv, module) p
-peekIpSrcLoc p = (# peek InfoProv, srcloc) p
-peekIpTyDesc p = (# peek InfoProv, ty_desc) p
+peekIpName, peekIpDesc, peekIpLabel, peekIpModule, peekIpSrcFile, peekIpSrcSpan, peekIpTyDesc :: Ptr InfoProv -> IO CString
+peekIpName p = (# peek InfoProv, table_name) p
+peekIpDesc p = (# peek InfoProv, closure_desc) p
+peekIpLabel p = (# peek InfoProv, label) p
+peekIpModule p = (# peek InfoProv, module) p
+peekIpSrcFile p = (# peek InfoProv, src_file) p
+peekIpSrcSpan p = (# peek InfoProv, src_span) p
+peekIpTyDesc p = (# peek InfoProv, ty_desc) p
peekInfoProv :: Ptr InfoProv -> IO InfoProv
peekInfoProv infop = do
@@ -69,14 +76,16 @@ peekInfoProv infop = do
tyDesc <- peekCString utf8 =<< peekIpTyDesc infop
label <- peekCString utf8 =<< peekIpLabel infop
mod <- peekCString utf8 =<< peekIpModule infop
- loc <- peekCString utf8 =<< peekIpSrcLoc infop
+ file <- peekCString utf8 =<< peekIpSrcFile infop
+ span <- peekCString utf8 =<< peekIpSrcSpan infop
return InfoProv {
ipName = name,
ipDesc = desc,
ipTyDesc = tyDesc,
ipLabel = label,
ipMod = mod,
- ipLoc = loc
+ ipSrcFile = file,
+ ipSrcSpan = span
}
-- | Get information about where a value originated from.
=====================================
libraries/base/GHC/MVar.hs
=====================================
@@ -18,7 +18,7 @@
-----------------------------------------------------------------------------
module GHC.MVar (
- -- * MVars
+ -- * MVars
MVar(..)
, newMVar
, newEmptyMVar
@@ -30,9 +30,15 @@ module GHC.MVar (
, tryReadMVar
, isEmptyMVar
, addMVarFinalizer
+
+ -- * PrimMVar
+ , PrimMVar
+ , newStablePtrPrimMVar
) where
import GHC.Base
+import GHC.Stable ( StablePtr(..) )
+import Unsafe.Coerce ( unsafeCoerce# )
data MVar a = MVar (MVar# RealWorld a)
{- ^
@@ -180,3 +186,17 @@ addMVarFinalizer :: MVar a -> IO () -> IO ()
addMVarFinalizer (MVar m) (IO finalizer) =
IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) }
+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 #)
+
=====================================
libraries/base/GHC/Stack.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Trustworthy #-}
@@ -27,8 +28,9 @@ module GHC.Stack (
-- * HasCallStack call stacks
CallStack, HasCallStack, callStack, emptyCallStack, freezeCallStack,
- fromCallSiteList, getCallStack, popCallStack, prettyCallStack,
+ fromCallSiteList, getCallStack, popCallStack,
pushCallStack, withFrozenCallStack,
+ prettyCallStackLines, prettyCallStack,
-- * Source locations
SrcLoc(..), prettySrcLoc,
@@ -48,12 +50,14 @@ module GHC.Stack (
renderStack
) where
+import GHC.Show
import GHC.Stack.CCS
import GHC.Stack.Types
import GHC.IO
import GHC.Base
import GHC.List
import GHC.Exception
+import Data.OldList (intercalate)
-- | Like the function 'error', but appends a stack trace to the error
-- message if one is available.
@@ -104,3 +108,32 @@ withFrozenCallStack do_this =
-- withFrozenCallStack's call-site
let ?callStack = freezeCallStack (popCallStack callStack)
in do_this
+
+-- 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/Stack/CCS.hs-boot
=====================================
@@ -14,3 +14,4 @@ module GHC.Stack.CCS where
import GHC.Base
currentCallStack :: IO [String]
+renderStack :: [String] -> String
=====================================
libraries/base/GHC/Stack/CloneStack.hs
=====================================
@@ -19,17 +19,19 @@ module GHC.Stack.CloneStack (
StackEntry(..),
cloneMyStack,
cloneThreadStack,
- decode
+ decode,
+ prettyStackEntry
) where
-import Control.Concurrent.MVar
+import GHC.MVar
import Data.Maybe (catMaybes)
-import Foreign
-import GHC.Conc.Sync
-import GHC.Exts (Int (I#), RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#)
+import GHC.Conc.Sync (ThreadId(ThreadId))
+import GHC.Int (Int (I#))
+import GHC.Prim (RealWorld, StackSnapshot#, ThreadId#, Array#, sizeofArray#, indexArray#, State#, StablePtr#)
import GHC.IO (IO (..))
import GHC.InfoProv (InfoProv (..), InfoProvEnt, ipeProv, peekInfoProv)
import GHC.Stable
+import GHC.Ptr
-- | A frozen snapshot of the state of an execution stack.
--
@@ -262,3 +264,7 @@ getDecodedStackArray (StackSnapshot s) =
stackEntryAt :: Array# (Ptr InfoProvEnt) -> Int -> Ptr InfoProvEnt
stackEntryAt stack (I# i) = case indexArray# stack i of
(# se #) -> se
+
+prettyStackEntry :: StackEntry -> String
+prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
+ " " ++ mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"
=====================================
libraries/base/GHC/Stack/CloneStack.hs-boot
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.Stack.CloneStack where
+
+import GHC.Base
+
+data StackSnapshot
+data StackEntry
+
+cloneMyStack :: IO StackSnapshot
+decode :: StackSnapshot -> IO [StackEntry]
+prettyStackEntry :: StackEntry -> String
=====================================
libraries/base/base.cabal
=====================================
@@ -208,6 +208,8 @@ Library
GHC.Err
GHC.Event.TimeOut
GHC.Exception
+ GHC.Exception.Backtrace
+ GHC.Exception.Context
GHC.Exception.Type
GHC.ExecutionStack
GHC.ExecutionStack.Internal
=====================================
rts/IPE.c
=====================================
@@ -85,7 +85,7 @@ void traceIPEFromHashTable(void *data STG_UNUSED, StgWord key STG_UNUSED,
traceIPE(ipe->info, ipe->prov.table_name, ipe->prov.closure_desc,
ipe->prov.ty_desc, ipe->prov.label, ipe->prov.module,
- ipe->prov.srcloc);
+ ipe->prov.src_file, ipe->prov.src_span);
}
#endif
@@ -144,7 +144,8 @@ void updateIpeMap() {
ip_ents[i].prov.ty_desc = &strings[ent->ty_desc];
ip_ents[i].prov.label = &strings[ent->label];
ip_ents[i].prov.module = &strings[ent->module_name];
- ip_ents[i].prov.srcloc = &strings[ent->srcloc];
+ ip_ents[i].prov.src_file = &strings[ent->src_file];
+ ip_ents[i].prov.src_span = &strings[ent->src_span];
insertHashTable(ipeMap, (StgWord) ent->info, &ip_ents[i]);
}
=====================================
rts/Trace.c
=====================================
@@ -681,21 +681,22 @@ void traceIPE(const StgInfoTable * info,
const char *ty_desc,
const char *label,
const char *module,
- const char *srcloc )
+ const char *src_file,
+ const char *src_span)
{
#if defined(DEBUG)
if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
ACQUIRE_LOCK(&trace_utx);
tracePreface();
- debugBelch("IPE: table_name %s, closure_desc %s, ty_desc %s, label %s, module %s, srcloc %s\n",
- table_name, closure_desc, ty_desc, label, module, srcloc);
+ debugBelch("IPE: table_name %s, closure_desc %s, ty_desc %s, label %s, module %s, srcloc %s:%s\n",
+ table_name, closure_desc, ty_desc, label, module, src_file, src_span);
RELEASE_LOCK(&trace_utx);
} else
#endif
if (eventlog_enabled) {
- postIPE((W_) INFO_PTR_TO_STRUCT(info), table_name, closure_desc, ty_desc, label, module, srcloc);
+ postIPE((W_) INFO_PTR_TO_STRUCT(info), table_name, closure_desc, ty_desc, label, module, src_file, src_span);
}
}
=====================================
rts/Trace.h
=====================================
@@ -331,12 +331,13 @@ void traceNonmovingHeapCensus(uint32_t log_blk_size,
const struct NonmovingAllocCensus *census);
void traceIPE(const StgInfoTable *info,
- const char *table_name,
- const char *closure_desc,
- const char *ty_desc,
- const char *label,
- const char *module,
- const char *srcloc );
+ const char *table_name,
+ const char *closure_desc,
+ const char *ty_desc,
+ const char *label,
+ const char *module,
+ const char *src_file,
+ const char *src_span);
void flushTrace(void);
#else /* !TRACING */
@@ -373,7 +374,7 @@ void flushTrace(void);
#define traceTaskDelete_(taskID) /* nothing */
#define traceHeapProfBegin(profile_id) /* nothing */
#define traceHeapProfCostCentre(ccID, label, module, srcloc, is_caf) /* nothing */
-#define traceIPE(info, table_name, closure_desc, ty_desc, label, module, srcloc) /* nothing */
+#define traceIPE(info, table_name, closure_desc, ty_desc, label, module, src_file, src_span) /* nothing */
#define traceHeapProfSampleBegin(era) /* nothing */
#define traceHeapBioProfSampleBegin(era, time) /* nothing */
#define traceHeapProfSampleEnd(era) /* nothing */
=====================================
rts/eventlog/EventLog.c
=====================================
@@ -166,7 +166,7 @@ static inline void postWord64(EventsBuf *eb, StgWord64 i)
postWord32(eb, (StgWord32)i);
}
-static inline void postBuf(EventsBuf *eb, StgWord8 *buf, uint32_t size)
+static inline void postBuf(EventsBuf *eb, const StgWord8 *buf, uint32_t size)
{
memcpy(eb->pos, buf, size);
eb->pos += size;
@@ -1417,7 +1417,8 @@ void postIPE(StgWord64 info,
const char *ty_desc,
const char *label,
const char *module,
- const char *srcloc)
+ const char *src_file,
+ const char *src_span)
{
ACQUIRE_LOCK(&eventBufMutex);
StgWord table_name_len = strlen(table_name);
@@ -1425,10 +1426,11 @@ void postIPE(StgWord64 info,
StgWord ty_desc_len = strlen(ty_desc);
StgWord label_len = strlen(label);
StgWord module_len = strlen(module);
- StgWord srcloc_len = strlen(srcloc);
+ StgWord src_file_len = strlen(src_file);
+ StgWord src_span_len = strlen(src_span);
// 8 for the info word
// 6 for the number of strings in the payload as postString adds 1 to the length
- StgWord len = 8+table_name_len+closure_desc_len+ty_desc_len+label_len+module_len+srcloc_len+6;
+ StgWord len = 8+table_name_len+closure_desc_len+ty_desc_len+label_len+module_len+src_file_len+1+src_span_len+6;
ensureRoomForVariableEvent(&eventBuf, len);
postEventHeader(&eventBuf, EVENT_IPE);
postPayloadSize(&eventBuf, len);
@@ -1438,7 +1440,13 @@ void postIPE(StgWord64 info,
postString(&eventBuf, ty_desc);
postString(&eventBuf, label);
postString(&eventBuf, module);
- postString(&eventBuf, srcloc);
+
+ // Manually construct the string "<file>:<span>\0"
+ postBuf(&eventBuf, (const StgWord8*) src_file, src_file_len);
+ StgWord8 colon = ':';
+ postBuf(&eventBuf, &colon, 1);
+ postString(&eventBuf, src_span);
+
RELEASE_LOCK(&eventBufMutex);
}
=====================================
rts/eventlog/EventLog.h
=====================================
@@ -196,7 +196,8 @@ void postIPE(StgWord64 info,
const char *ty_desc,
const char *label,
const char *module,
- const char *srcloc);
+ const char *src_file,
+ const char *src_span);
void postConcUpdRemSetFlush(Capability *cap);
void postConcMarkEnd(StgWord32 marked_obj_count);
=====================================
rts/include/rts/IPE.h
=====================================
@@ -19,7 +19,8 @@ typedef struct InfoProv_ {
const char *ty_desc;
const char *label;
const char *module;
- const char *srcloc;
+ const char *src_file;
+ const char *src_span;
} InfoProv;
typedef struct InfoProvEnt_ {
@@ -51,7 +52,8 @@ typedef struct {
StringIdx ty_desc;
StringIdx label;
StringIdx module_name;
- StringIdx srcloc;
+ StringIdx src_file;
+ StringIdx src_span;
} IpeBufferEntry;
typedef struct IpeBufferListNode_ {
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5a3d3587b22da3928396d4698c28eaf2cee6c1a2...b5d9acb1e7a5cba4a510eae4fe9ee7ad22439b46
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5a3d3587b22da3928396d4698c28eaf2cee6c1a2...b5d9acb1e7a5cba4a510eae4fe9ee7ad22439b46
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220819/a7b3b777/attachment-0001.html>
More information about the ghc-commits
mailing list