ghc-internal 9.1203.0 → 9.1204.0

raw patch · 5 files changed

+80/−22 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ghc-internal.cabal +1/−1
• src/GHC/Internal/Err.hs +10/−2
• src/GHC/Internal/Exception.hs +4/−3
• src/GHC/Internal/Exception/Backtrace.hs +63/−10
• src/GHC/Internal/Exception/Backtrace.hs-boot +2/−6

@@ -4,7 +4,7 @@ name:           ghc-internal -- The project is ghc's version plus ghc-internal's version suffix. -- For example, for ghc=9.10.1, ghc-internal's version will be 9.1001.0.-version:        9.1203.0+version:        9.1204.0 license:        BSD-3-Clause license-file:   LICENSE maintainer:     The GHC Developers <ghc-devs@haskell.org>

@@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} {-# LANGUAGE RankNTypes, PolyKinds, DataKinds #-}+{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-}  -----------------------------------------------------------------------------@@ -26,6 +27,7 @@ import GHC.Types (Char, RuntimeRep) import GHC.Internal.Stack.Types import GHC.Prim+import GHC.Magic ( noinline ) import {-# SOURCE #-} GHC.Internal.Exception   ( errorCallWithCallStackException   , errorCallException )@@ -33,7 +35,10 @@ -- | 'error' stops execution and displays an error message. error :: forall (r :: RuntimeRep). forall (a :: TYPE r).          HasCallStack => [Char] -> a-error s = raise# (errorCallWithCallStackException s ?callStack)+error s =+  -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw]+  let !se = noinline (errorCallWithCallStackException s ?callStack)+  in raise# se           -- Bleh, we should be using 'GHC.Internal.Stack.callStack' instead of           -- '?callStack' here, but 'GHC.Internal.Stack.callStack' depends on           -- 'GHC.Internal.Stack.popCallStack', which is partial and depends on@@ -73,7 +78,10 @@ -- nor wanted (see #19886). We’d like to use withFrozenCallStack, but that -- is not available in this module yet, and making it so is hard. So let’s just -- use raise# directly.-undefined = raise# (errorCallWithCallStackException "Prelude.undefined" ?callStack)+undefined =+    -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw]+    let !se = noinline (errorCallWithCallStackException "Prelude.undefined" ?callStack)+    in raise# se  -- | Used for compiler-generated error message; -- encoding saves bytes of string junk.

@@ -70,7 +70,8 @@ import GHC.Internal.Stack.Types import GHC.Internal.IO.Unsafe import {-# SOURCE #-} GHC.Internal.Stack (prettyCallStackLines, prettyCallStack, prettySrcLoc, withFrozenCallStack)-import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectBacktraces)+import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectExceptionAnnotation)+import GHC.Internal.Exception.Context (SomeExceptionAnnotation(..)) import GHC.Internal.Exception.Type  -- | Throw an exception.  Exceptions may be thrown from purely@@ -166,8 +167,8 @@                          => e -> IO SomeException toExceptionWithBacktrace e   | backtraceDesired e = do-      bt <- collectBacktraces-      return (addExceptionContext bt (toException e))+      SomeExceptionAnnotation ea <- collectExceptionAnnotation+      return (addExceptionContext ea (toException e))   | otherwise = return (toException e)  -- | This is thrown when the user calls 'error'. The @String@ is the

@@ -3,7 +3,20 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -module GHC.Internal.Exception.Backtrace where+module GHC.Internal.Exception.Backtrace+    ( -- * Backtrace mechanisms+      BacktraceMechanism(..)+    , getBacktraceMechanismState+    , setBacktraceMechanismState+      -- * Collecting backtraces+    , Backtraces(..)+    , displayBacktraces+    , collectBacktraces+    , CollectExceptionAnnotationMechanism+    , getCollectExceptionAnnotationMechanism+    , setCollectExceptionAnnotation+    , collectExceptionAnnotation+    ) where  import GHC.Internal.Base import GHC.Internal.Data.OldList@@ -11,9 +24,9 @@ import GHC.Internal.IO.Unsafe (unsafePerformIO) import GHC.Internal.Exception.Context import GHC.Internal.Ptr-import GHC.Internal.Stack.Types as GHC.Stack (CallStack)+import GHC.Internal.Data.Maybe (fromMaybe)+import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack) import qualified GHC.Internal.Stack as HCS-import qualified GHC.Internal.ExecutionStack as ExecStack import qualified GHC.Internal.ExecutionStack.Internal as ExecStack import qualified GHC.Internal.Stack.CloneStack as CloneStack import qualified GHC.Internal.Stack.CCS as CCS@@ -86,13 +99,44 @@     _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled)     return () +-- | How to collect 'ExceptionAnnotation's on throwing 'Exception's.+--+data CollectExceptionAnnotationMechanism = CollectExceptionAnnotationMechanism+  { ceaCollectExceptionAnnotationMechanism :: HasCallStack => IO SomeExceptionAnnotation+  }++defaultCollectExceptionAnnotationMechanism :: CollectExceptionAnnotationMechanism+defaultCollectExceptionAnnotationMechanism = CollectExceptionAnnotationMechanism+  { ceaCollectExceptionAnnotationMechanism = SomeExceptionAnnotation `fmap` collectBacktraces+  }++collectExceptionAnnotationMechanismRef :: IORef CollectExceptionAnnotationMechanism+collectExceptionAnnotationMechanismRef =+    unsafePerformIO $ newIORef defaultCollectExceptionAnnotationMechanism+{-# NOINLINE collectExceptionAnnotationMechanismRef #-}++-- | Returns the current callback for collecting 'ExceptionAnnotation's on throwing 'Exception's.+--+getCollectExceptionAnnotationMechanism :: IO CollectExceptionAnnotationMechanism+getCollectExceptionAnnotationMechanism = readIORef collectExceptionAnnotationMechanismRef++-- | Set the callback for collecting an 'ExceptionAnnotation'.+--+setCollectExceptionAnnotation :: ExceptionAnnotation a => (HasCallStack => IO a) -> IO ()+setCollectExceptionAnnotation collector = do+  let cea = CollectExceptionAnnotationMechanism+        { ceaCollectExceptionAnnotationMechanism = fmap SomeExceptionAnnotation collector+        }+  _ <- atomicModifyIORef'_ collectExceptionAnnotationMechanismRef (const cea)+  return ()+ -- | A collection of backtraces. data Backtraces =     Backtraces {         btrCostCentre :: Maybe (Ptr CCS.CostCentreStack),         btrHasCallStack :: Maybe HCS.CallStack,-        btrExecutionStack :: Maybe [ExecStack.Location],-        btrIpe :: Maybe [CloneStack.StackEntry]+        btrExecutionStack :: Maybe ExecStack.StackTrace,+        btrIpe :: Maybe CloneStack.StackSnapshot     }  -- | Render a set of backtraces to a human-readable string.@@ -109,8 +153,10 @@      -- The unsafePerformIO here is safe as we don't currently unload cost-centres.     displayCc   = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings-    displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "")-    displayIpe  = unlines . map (indent 2 . CloneStack.prettyStackEntry)+    displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames+    -- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor+    -- references closures can be garbage collected.+    displayIpe  = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode     displayHsc  = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack       where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc @@ -122,6 +168,14 @@ instance ExceptionAnnotation Backtraces where     displayExceptionAnnotation = displayBacktraces +-- | Collect 'SomeExceptionAnnotation' based on the configuration of the+-- global 'CollectExceptionAnnotationMechanism'.+--+collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation+collectExceptionAnnotation = HCS.withFrozenCallStack $ do+  cea <- getCollectExceptionAnnotationMechanism+  ceaCollectExceptionAnnotationMechanism cea+ -- | Collect a set of 'Backtraces'. collectBacktraces :: (?callStack :: CallStack) => IO Backtraces collectBacktraces = HCS.withFrozenCallStack $ do@@ -140,12 +194,11 @@         Just `fmap` CCS.getCurrentCCS ()      exec <- collect ExecutionBacktrace $ do-        ExecStack.getStackTrace+        ExecStack.collectStackTrace      ipe <- collect IPEBacktrace $ do         stack <- CloneStack.cloneMyStack-        stackEntries <- CloneStack.decode stack-        return (Just stackEntries)+        return (Just stack)      hcs <- collect HasCallStackBacktrace $ do         return (Just ?callStack)

@@ -5,11 +5,7 @@  import GHC.Internal.Base (IO) import GHC.Internal.Stack.Types (HasCallStack)-import GHC.Internal.Exception.Context (ExceptionAnnotation)--data Backtraces--instance ExceptionAnnotation Backtraces+import GHC.Internal.Exception.Context (SomeExceptionAnnotation)  -- For GHC.Exception-collectBacktraces :: HasCallStack => IO Backtraces+collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation