[Git][ghc/ghc][wip/T18159] Implement T18159

[Ben Gamari]

Ben Gamari pushed to branch wip/T18159 at Glasgow Haskell Compiler / GHC


Commits:
48724254 by Ben Gamari at 2020-05-08T14:59:50-04:00
Implement T18159

- - - - -


4 changed files:

- + libraries/base/GHC/Exception/Backtrace.hs
- + libraries/base/GHC/Exception/Backtrace.hs-boot
- libraries/base/GHC/Exception/Type.hs
- libraries/base/base.cabal


Changes:

=====================================
libraries/base/GHC/Exception/Backtrace.hs
=====================================
@@ -0,0 +1,91 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE NoImplicitPrelude
+           , ExistentialQuantification
+           , MagicHash
+           , RecordWildCards
+           , PatternSynonyms
+  #-}
+{-# OPTIONS_HADDOCK not-home #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.Exception.Backtrace
+-- Copyright   :  (c) The University of Glasgow, 2020-2025
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc at haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC extensions)
+--
+-- Exception backtraces.
+--
+-----------------------------------------------------------------------------
+
+module GHC.Exception.Backtrace
+       ( Backtrace(..)
+       , setGlobalBacktraceMechanism
+       , getGlobalBacktraceMechanism
+       ) where
+
+import GHC.Ptr
+import GHC.Stack.CCS
+import GHC.Stack
+import GHC.ExecutionStack
+import GHC.Base
+import GHC.Show
+
+-- | An exception backtrace.
+--
+-- @since 4.15
+data Backtrace
+    = CostCenterBacktrace (Ptr GHC.Stack.CCS.CostCentreStack)
+      -- ^ a cost center profiler backtrace
+    | HasCallStackBacktrace GHC.Stack.CallStack
+      -- ^ a stack from 'GHC.Stack.HasCallStack'
+    | ExecutionBacktrace [GHC.ExecutionStack.Location]
+      -- ^ a stack unwinding (e.g. DWARF) backtrace
+
+-- | @since 4.15
+instance Show Backtrace where
+    -- TODO
+    showsPrec p (CostCenterBacktrace ccs) = showsPrec p ccs
+    showsPrec p (HasCallStackBacktrace ccs) = showsPrec p ccs
+    showsPrec p (ExecutionBacktrace ccs) = showsPrec p ccs
+
+-- | How to collect a backtrace when an exception is thrown.
+data BacktraceMechanism
+    = NoBacktrace
+      -- ^ don't collect a backtrace
+    | CostCenterBacktrace
+      -- ^ collect a cost center stacktrace (only available when built with profiling)
+    | ExecutionStackBacktrace (Maybe Int)
+      -- ^ use execution stack unwinding with given limit
+
+currentBacktraceMechanism :: IORef BacktraceMechanism
+currentBacktraceMechanism = unsafePerformIO $ mkIORef Nothing
+{-# NOINLINE currentBacktraceMechanism #-}
+
+-- | Set how 'Control.Exception.throwIO', et al. collect backtraces.
+setGlobalBacktraceMechanism :: BacktraceMechanism -> IO ()
+setGlobalBacktraceMechanism = writeIORef currentBacktraceMechanism
+
+-- | Returns the currently selected 'BacktraceMechanism'.
+getGlobalBacktraceMechanism :: IO BacktraceMechanism
+getGlobalBacktraceMechanism = readIORef currentBacktraceMechanism
+
+-- | Collect a 'Backtrace' via the current global 'BacktraceMechanism'. See
+-- 'setGlobalBacktraceMechanism'.
+collectBacktrace :: IO (Maybe Backtrace)
+collectBacktrace = do
+    mech <- getGlobalBacktraceMechanism
+    collectBacktrace' mech
+
+-- | Collect a 'Backtrace' via the given 'BacktraceMechanism'.
+collectBacktrace' :: BacktraceMechanism -> IO (Maybe Backtrace)
+collectBacktrace' NoBacktrace = Nothing
+collectBacktrace' CostCenterBacktrace = do
+  ptr <- getCurrentCCS ()
+  -- TODO: is the unit here safe? Is this dummy argument really needed? Why
+  -- isn't the state token sufficient?
+  return $ if ptr == nullPtr then Nothing else Just (CostCenterBacktrace ptr)
+collectBacktrace' ExecutionStackBacktrace = fmap ExecutionBacktrace <$> getStackTrace


=====================================
libraries/base/GHC/Exception/Backtrace.hs-boot
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.Exception.Backtrace (Backtrace) where
+
+import GHC.Show
+
+data Backtrace
+instance Show Backtrace


=====================================
libraries/base/GHC/Exception/Type.hs
=====================================
@@ -22,12 +22,18 @@
 -----------------------------------------------------------------------------
 
 module GHC.Exception.Type
-       ( Exception(..)    -- Class
-       , SomeException(..), ArithException(..)
+       ( -- * Fundamentals
+         Exception(..)
+       , SomeException(..)
+       , pattern SomeException
+         -- * Concrete exception types
+       , ArithException(..)
        , divZeroException, overflowException, ratioZeroDenomException
        , underflowException
        ) where
 
+import {-# SOURCE #-} GHC.Exception.Backtrace (Backtrace)
+
 import Data.Maybe
 import Data.Typeable (Typeable, cast)
    -- loop: Data.Typeable -> GHC.Err -> GHC.Exception
@@ -39,11 +45,23 @@ 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 => SomeExceptionWithLocation (Maybe Backtrace) e
 
 -- | @since 3.0
 instance Show SomeException where
-    showsPrec p (SomeException e) = showsPrec p e
+        -- TODO: Should this obey the usual Show-is-Haskell invariant?
+    showsPrec p (SomeExceptionWithLocation mb_bt e) =
+        showsPrec p e <> backtrace
+      where
+        backtrace =
+          case mb_bt of
+            Nothing -> ""
+            Just bt -> "\nBacktrace:\n" <> show bt
+
+pattern SomeException e <- SomeExceptionWithLocation _ e
+  where
+    SomeException e = SomeExceptionWithLocation Nothing e
+
 
 {- |
 Any type that you wish to throw or catch as an exception must be an


=====================================
libraries/base/base.cabal
=====================================
@@ -218,6 +218,7 @@ Library
         GHC.Environment
         GHC.Err
         GHC.Exception
+        GHC.Exception.Backtrace
         GHC.Exception.Type
         GHC.ExecutionStack
         GHC.ExecutionStack.Internal



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/487242546d9ede9af56d08ca7510aacc753f058b

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/487242546d9ede9af56d08ca7510aacc753f058b
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/20200508/2bdd3201/attachment-0001.html>