[Git][ghc/ghc][wip/exception-context] 12 commits: base: Factor out errorBelch
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Thu Oct 20 14:04:31 UTC 2022
Ben Gamari pushed to branch wip/exception-context at Glasgow Haskell Compiler / GHC
Commits:
849c5d9c by Ben Gamari at 2022-10-20T10:03:39-04:00
base: Factor out errorBelch
This was useful when debugging
- - - - -
298b950b by Ben Gamari at 2022-10-20T10:03:39-04:00
base: Clean up imports of GHC.ExecutionStack
- - - - -
ed98667f by Ben Gamari at 2022-10-20T10:03:39-04:00
base: Clean up imports of GHC.Stack.CloneStack
- - - - -
627007ff by Ben Gamari at 2022-10-20T10:03:39-04:00
base: Move prettyCallStack to GHC.Stack
- - - - -
a07e5a2e by Ben Gamari at 2022-10-20T10:03:39-04:00
base: Move PrimMVar to GHC.MVar
- - - - -
36443c9f by Ben Gamari at 2022-10-20T10:03:39-04:00
base: Introduce exception context
- - - - -
a493cbc5 by Ben Gamari at 2022-10-20T10:03:39-04:00
base: Introduce exception backtrace infrastructure
- - - - -
32dff04d by Ben Gamari at 2022-10-20T10:03:39-04:00
base: Collect backtraces in GHC.IO.throwIO
- - - - -
41273d52 by Ben Gamari at 2022-10-20T10:03:39-04:00
base: Collect backtraces in GHC.Exception.throw
- - - - -
f8d21fbc by Ben Gamari at 2022-10-20T10:03:39-04:00
base: Force thrown toException applicatoins
This ensures that exceptions can be reliably inspected in GHCi.
- - - - -
61580842 by Ben Gamari at 2022-10-20T10:04:13-04:00
Update test output
- - - - -
89e97886 by Ben Gamari at 2022-10-20T10:04:13-04:00
base: Add HasCallStack constraints to io{Error,Exception}
- - - - -
26 changed files:
- libraries/base/Control/Exception.hs
- libraries/base/Control/Exception/Base.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/Internal.hsc
- libraries/base/GHC/IO.hs
- libraries/base/GHC/IO/Exception.hs
- libraries/base/GHC/MVar.hs
- libraries/base/GHC/Stack.hs
- + libraries/base/GHC/Stack.hs-boot
- libraries/base/GHC/Stack/CCS.hs-boot
- libraries/base/GHC/Stack/CloneStack.hs
- libraries/base/GHC/TopHandler.hs
- libraries/base/System/Timeout.hs
- libraries/base/base.cabal
- libraries/base/tests/IO/T21336/T21336a.stderr
- libraries/base/tests/IO/T21336/T21336b.stderr
- libraries/base/tests/T13167.stderr
- testsuite/tests/ghci.debugger/scripts/T14690.stdout
- testsuite/tests/ghci.debugger/scripts/break024.stdout
Changes:
=====================================
libraries/base/Control/Exception.hs
=====================================
@@ -43,6 +43,7 @@ module Control.Exception (
SomeAsyncException(..),
AsyncException(..), -- instance Eq, Ord, Show, Typeable, Exception
asyncExceptionToException, asyncExceptionFromException,
+ asyncExceptionToExceptionWithContext,
NonTermination(..),
NestedAtomically(..),
=====================================
libraries/base/Control/Exception/Base.hs
=====================================
@@ -26,7 +26,7 @@ module Control.Exception.Base (
ArrayException(..),
AssertionFailed(..),
SomeAsyncException(..), AsyncException(..),
- asyncExceptionToException, asyncExceptionFromException,
+ asyncExceptionToException, asyncExceptionToExceptionWithContext, asyncExceptionFromException,
NonTermination(..),
NestedAtomically(..),
BlockedIndefinitelyOnMVar(..),
=====================================
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 {-# SOURCE #-} GHC.Exception.Backtrace (collectBacktraces)
+import GHC.Exception.Context
import GHC.Exception.Type
-- | Throw an exception. Exceptions may be thrown from purely
@@ -48,8 +54,11 @@ 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
+ !exc = toExceptionWithContext e context
+ in raise# exc
-- | This is thrown when the user calls 'error'. The first @String@ is the
-- argument given to 'error', second @String@ is the location.
@@ -89,31 +98,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,100 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module GHC.Exception.Backtrace
+ ( -- * Backtrace mechanisms
+ BacktraceMechanism(..)
+ , setEnabledBacktraceMechanisms
+ , getEnabledBacktraceMechanisms
+ -- * Collecting backtraces
+ , collectBacktraces
+ , collectBacktrace
+ ) where
+
+import GHC.Base
+import Data.OldList
+import GHC.IORef
+import GHC.IO.Unsafe (unsafePerformIO)
+import GHC.Show (Show)
+import GHC.Exception.Context
+import GHC.Stack.Types (HasCallStack, CallStack)
+import qualified GHC.Stack as CallStack
+import qualified GHC.ExecutionStack as ExecStack
+import qualified GHC.Stack.CloneStack as CloneStack
+import qualified GHC.Stack.CCS as CCS
+
+-- | How to collect a backtrace when an exception is thrown.
+data BacktraceMechanism
+ = -- | collect cost-centre stack backtraces (only available when built with profiling)
+ CostCentreBacktraceMech
+ | -- | collect backtraces from native execution stack unwinding
+ ExecutionStackBacktraceMech -- TODO: unwind limit?
+ | -- | collect backtraces from Info Table Provenance Entries
+ IPEBacktraceMech
+ | -- | collect 'HasCallStack' backtraces
+ HasCallStackBacktraceMech
+ deriving (Eq, Show)
+
+enabledBacktraceMechanisms :: IORef [BacktraceMechanism]
+enabledBacktraceMechanisms = unsafePerformIO $ newIORef [HasCallStackBacktraceMech]
+{-# NOINLINE enabledBacktraceMechanisms #-}
+
+-- | Set how 'Control.Exception.throwIO', et al. collect backtraces.
+setEnabledBacktraceMechanisms :: [BacktraceMechanism] -> IO ()
+setEnabledBacktraceMechanisms = writeIORef enabledBacktraceMechanisms
+
+-- | Returns the currently enabled 'BacktraceMechanism's.
+getEnabledBacktraceMechanisms :: IO [BacktraceMechanism]
+getEnabledBacktraceMechanisms = readIORef enabledBacktraceMechanisms
+
+collectBacktraces :: HasCallStack => IO ExceptionContext
+collectBacktraces = do
+ mechs <- getEnabledBacktraceMechanisms
+ mconcat `fmap` mapM collectBacktrace mechs
+
+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,15 @@
module GHC.Exception.Type
( Exception(..) -- Class
- , SomeException(..), ArithException(..)
+ , SomeException(..)
+ , exceptionContext
+ , addExceptionContext
+ -- * Exception context
+ , ExceptionContext(..)
+ , emptyExceptionContext
+ , mergeExceptionContexts
+ -- * Arithmetic exceptions
+ , ArithException(..)
, divZeroException, overflowException, ratioZeroDenomException
, underflowException
) where
@@ -30,13 +39,24 @@ 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, ?context :: ExceptionContext) => SomeException e
+
+-- | Extract the 'ExceptionContext' of a 'SomeException'.
+exceptionContext :: SomeException -> ExceptionContext
+exceptionContext (SomeException _) = ?context
+
+-- | Add more 'ExceptionContext' to a 'SomeException'.
+addExceptionContext :: ExceptionContext -> SomeException -> SomeException
+addExceptionContext ctxt' se@(SomeException e) =
+ let ?context = exceptionContext se `mergeExceptionContexts` ctxt'
+ in SomeException e
-- | @since 3.0
instance Show SomeException where
@@ -129,10 +149,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 ?context = ctxt
fromException (SomeException e) = cast e
-- | Render this exception value in a human-friendly manner.
@@ -146,8 +169,16 @@ class (Typeable e, Show e) => Exception e where
-- | @since 3.0
instance Exception SomeException where
toException se = se
+ toExceptionWithContext se ctxt = addExceptionContext ctxt se
fromException = Just
- displayException (SomeException e) = displayException e
+ displayException (SomeException e) =
+ displayException e ++ "\n" ++ displayContext ?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/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/IO.hs
=====================================
@@ -47,8 +47,10 @@ import GHC.ST
import GHC.Exception
import GHC.Show
import GHC.IO.Unsafe
+import GHC.Stack.Types ( HasCallStack )
import Unsafe.Coerce ( unsafeCoerce )
+import {-# SOURCE #-} GHC.Exception.Backtrace ( collectBacktraces )
import {-# SOURCE #-} GHC.IO.Exception ( userError, IOError )
-- ---------------------------------------------------------------------------
@@ -235,8 +237,11 @@ 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
+ let !exc = toExceptionWithContext e ctxt
+ IO (raiseIO# exc)
-- -----------------------------------------------------------------------------
-- Controlling asynchronous exception delivery
=====================================
libraries/base/GHC/IO/Exception.hs
=====================================
@@ -28,7 +28,7 @@ module GHC.IO.Exception (
cannotCompactFunction, cannotCompactPinned, cannotCompactMutable,
SomeAsyncException(..),
- asyncExceptionToException, asyncExceptionFromException,
+ asyncExceptionToException, asyncExceptionToExceptionWithContext, asyncExceptionFromException,
AsyncException(..), stackOverflow, heapOverflow,
ArrayException(..),
@@ -56,6 +56,7 @@ import GHC.Exception
import GHC.IO.Handle.Types
import GHC.OldList ( intercalate )
import {-# SOURCE #-} GHC.Stack.CCS
+import GHC.Stack.Types (HasCallStack)
import Foreign.C.Types
import Data.Typeable ( cast )
@@ -183,18 +184,22 @@ instance Show SomeAsyncException where
-- | @since 4.7.0.0
instance Exception SomeAsyncException
--- |@since 4.7.0.0
+-- | @since 4.7.0.0
asyncExceptionToException :: Exception e => e -> SomeException
asyncExceptionToException = toException . SomeAsyncException
--- |@since 4.7.0.0
+-- | @since 4.18.0.0
+asyncExceptionToExceptionWithContext :: Exception e => e -> ExceptionContext -> SomeException
+asyncExceptionToExceptionWithContext e ctxt =
+ addExceptionContext ctxt (asyncExceptionToException e)
+
+-- | @since 4.7.0.0
asyncExceptionFromException :: Exception e => SomeException -> Maybe e
asyncExceptionFromException x = do
SomeAsyncException a <- fromException x
cast a
-
--- |Asynchronous exceptions.
+-- | Asynchronous exceptions.
data AsyncException
= StackOverflow
-- ^The current thread\'s stack exceeded its limit.
@@ -233,6 +238,7 @@ data AsyncException
-- | @since 4.7.0.0
instance Exception AsyncException where
toException = asyncExceptionToException
+ toExceptionWithContext = asyncExceptionToExceptionWithContext
fromException = asyncExceptionFromException
-- | Exceptions generated by array operations
@@ -305,11 +311,11 @@ data ExitCode
-- | @since 4.1.0.0
instance Exception ExitCode
-ioException :: IOException -> IO a
+ioException :: HasCallStack => IOException -> IO a
ioException err = throwIO err
-- | Raise an 'IOError' in the 'IO' monad.
-ioError :: IOError -> IO a
+ioError :: HasCallStack => IOError -> IO a
ioError = ioException
-- ---------------------------------------------------------------------------
=====================================
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.hs-boot
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.Stack where
+
+import GHC.Base
+import GHC.Stack.Types (CallStack, SrcLoc)
+
+prettyCallStackLines :: CallStack -> [String]
+prettyCallStack :: CallStack -> String
+prettySrcLoc :: SrcLoc -> String
=====================================
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, ipLoc, 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/TopHandler.hs
=====================================
@@ -198,13 +198,17 @@ real_handler exit se = do
-- don't use errorBelch() directly, because we cannot call varargs functions
-- using the FFI.
foreign import ccall unsafe "HsBase.h errorBelch2"
- errorBelch :: CString -> CString -> IO ()
+ c_errorBelch :: CString -> CString -> IO ()
+
+errorBelch :: String -> IO ()
+errorBelch msg =
+ withCAString "%s" $ \fmt ->
+ withCAString msg $ \msg' ->
+ c_errorBelch fmt msg'
disasterHandler :: (Int -> IO a) -> IOError -> IO a
disasterHandler exit _ =
- withCAString "%s" $ \fmt ->
- withCAString msgStr $ \msg ->
- errorBelch fmt msg >> exit 1
+ errorBelch msgStr >> exit 1
where
msgStr =
"encountered an exception while trying to report an exception.\n" ++
=====================================
libraries/base/System/Timeout.hs
=====================================
@@ -27,6 +27,7 @@ import Control.Concurrent
import Control.Exception (Exception(..), handleJust, bracket,
uninterruptibleMask_,
asyncExceptionToException,
+ asyncExceptionToExceptionWithContext,
asyncExceptionFromException)
import Data.Unique (Unique, newUnique)
@@ -52,6 +53,7 @@ instance Show Timeout where
-- | @since 4.7.0.0
instance Exception Timeout where
toException = asyncExceptionToException
+ toExceptionWithContext = asyncExceptionToExceptionWithContext
fromException = asyncExceptionFromException
-- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result
=====================================
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
=====================================
libraries/base/tests/IO/T21336/T21336a.stderr
=====================================
@@ -1 +1,15 @@
Exception during Weak# finalization (ignored): GHC.IO.FD.fdWrite: resource exhausted (No space left on device)
+HasCallStack backtrace:
+CallStack (from HasCallStack):
+ collectBacktrace, called at libraries/base/GHC/Exception/Backtrace.hs:54:25 in base:GHC.Exception.Backtrace
+ collectBacktraces, called at libraries/base/GHC/IO.hs:242:13 in base:GHC.IO
+ throwIO, called at libraries/base/GHC/IO/Exception.hs:315:19 in base:GHC.IO.Exception
+ ioException, called at libraries/base/GHC/IO/Exception.hs:319:20 in base:GHC.IO.Exception
+ ioError, called at libraries/base/Foreign/C/Error.hs:288:5 in base:Foreign.C.Error
+HasCallStack backtrace:
+CallStack (from HasCallStack):
+ collectBacktrace, called at libraries/base/GHC/Exception/Backtrace.hs:54:25 in base:GHC.Exception.Backtrace
+ collectBacktraces, called at libraries/base/GHC/IO.hs:242:13 in base:GHC.IO
+ throwIO, called at libraries/base/GHC/IO/Handle/Internals.hs:446:17 in base:GHC.IO.Handle.Internals
+
+
=====================================
libraries/base/tests/IO/T21336/T21336b.stderr
=====================================
@@ -1 +1,8 @@
Exception during Weak# finalization (ignored): <stdout>: hFlush: resource exhausted (No space left on device)
+HasCallStack backtrace:
+CallStack (from HasCallStack):
+ collectBacktrace, called at libraries/base/GHC/Exception/Backtrace.hs:54:25 in base:GHC.Exception.Backtrace
+ collectBacktraces, called at libraries/base/GHC/IO.hs:242:13 in base:GHC.IO
+ throwIO, called at libraries/base/GHC/IO/Exception.hs:309:19 in base:GHC.IO.Exception
+
+
=====================================
libraries/base/tests/T13167.stderr
=====================================
@@ -1,4 +1,32 @@
Exception during Weak# finalization (ignored): failed
+HasCallStack backtrace:
+CallStack (from HasCallStack):
+ collectBacktrace, called at libraries/base/GHC/Exception/Backtrace.hs:54:25 in base:GHC.Exception.Backtrace
+ collectBacktraces, called at libraries/base/GHC/IO.hs:242:13 in base:GHC.IO
+ throwIO, called at T13167.hs:23:5 in main:Main
+
+
Exception during Weak# finalization (ignored): failed
+HasCallStack backtrace:
+CallStack (from HasCallStack):
+ collectBacktrace, called at libraries/base/GHC/Exception/Backtrace.hs:54:25 in base:GHC.Exception.Backtrace
+ collectBacktraces, called at libraries/base/GHC/IO.hs:242:13 in base:GHC.IO
+ throwIO, called at T13167.hs:23:5 in main:Main
+
+
Exception during Weak# finalization (ignored): failed
+HasCallStack backtrace:
+CallStack (from HasCallStack):
+ collectBacktrace, called at libraries/base/GHC/Exception/Backtrace.hs:54:25 in base:GHC.Exception.Backtrace
+ collectBacktraces, called at libraries/base/GHC/IO.hs:242:13 in base:GHC.IO
+ throwIO, called at T13167.hs:23:5 in main:Main
+
+
Exception during Weak# finalization (ignored): failed
+HasCallStack backtrace:
+CallStack (from HasCallStack):
+ collectBacktrace, called at libraries/base/GHC/Exception/Backtrace.hs:54:25 in base:GHC.Exception.Backtrace
+ collectBacktraces, called at libraries/base/GHC/IO.hs:242:13 in base:GHC.IO
+ throwIO, called at T13167.hs:23:5 in main:Main
+
+
=====================================
testsuite/tests/ghci.debugger/scripts/T14690.stdout
=====================================
@@ -1,10 +1,12 @@
Stopped in <exception thrown>, <unknown>
-_exception :: e = _
+_exception :: e = 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.SomeException
+ (GHC.Exception.ErrorCallWithLocation _ _)
:steplocal is not possible.
Cannot determine current top-level binding after a break on error / exception.
Use :stepmodule.
=====================================
testsuite/tests/ghci.debugger/scripts/break024.stdout
=====================================
@@ -1,12 +1,14 @@
Left user error (error)
Stopped in <exception thrown>, <unknown>
-_exception :: e = _
+_exception :: e = SomeException
+ (GHC.IO.Exception.IOError Nothing GHC.IO.Exception.UserError ....)
_exception = 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 = SomeException
+ (GHC.IO.Exception.IOError Nothing GHC.IO.Exception.UserError ....)
_exception = SomeException
(GHC.IO.Exception.IOError
Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing)
@@ -14,7 +16,8 @@ Stopped in <exception thrown>, <unknown>
_exception :: e = SomeException
(GHC.IO.Exception.IOError Nothing GHC.IO.Exception.UserError ....)
Stopped in <exception thrown>, <unknown>
-_exception :: e = _
+_exception :: e = SomeException
+ (GHC.IO.Exception.IOError Nothing GHC.IO.Exception.UserError ....)
_exception = SomeException
(GHC.IO.Exception.IOError
Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a8fa5b4e0961a023d04cef1f01af5eb8b3d5a4f...89e978867c7e8b69103bd19c0f34636082c7e4b1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a8fa5b4e0961a023d04cef1f01af5eb8b3d5a4f...89e978867c7e8b69103bd19c0f34636082c7e4b1
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/20221020/5cc25227/attachment-0001.html>
More information about the ghc-commits
mailing list