[Git][ghc/ghc][wip/exception-context] 7 commits: base: Clean up imports of GHC.ExecutionStack
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri Aug 19 22:08:00 UTC 2022
Ben Gamari pushed to branch wip/exception-context at Glasgow Haskell Compiler / GHC
Commits:
d29caa82 by Ben Gamari at 2022-08-19T18:02:03-04:00
base: Clean up imports of GHC.ExecutionStack
- - - - -
7392c518 by Ben Gamari at 2022-08-19T18:02:03-04:00
base: Clean up imports of GHC.Stack.CloneStack
- - - - -
c5d3efb1 by Ben Gamari at 2022-08-19T18:04:18-04:00
base: Move prettyCallStack to GHC.Stack
- - - - -
89373322 by Ben Gamari at 2022-08-19T18:07:09-04:00
base: Introduce exception context
- - - - -
bc5ed676 by Ben Gamari at 2022-08-19T18:07:40-04:00
base: Backtraces
- - - - -
e69b0c7d by Ben Gamari at 2022-08-19T18:07:53-04:00
base: Collect backtraces in GHC.IO.throwIO
- - - - -
e0998cce by Ben Gamari at 2022-08-19T18:07:53-04:00
base: Collect backtraces in GHC.Exception.throw
- - - - -
16 changed files:
- 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/IO.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/Stack/CloneStack.hs-boot
- libraries/base/base.cabal
Changes:
=====================================
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/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/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/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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53f5367e9f221be99a6c7b81ff60171bcbc59a82...e0998ccec48d57951228581c6090dbfb8ab5796f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53f5367e9f221be99a6c7b81ff60171bcbc59a82...e0998ccec48d57951228581c6090dbfb8ab5796f
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/f7323462/attachment-0001.html>
More information about the ghc-commits
mailing list