[Git][ghc/ghc][wip/exception-context] 3 commits: Mechanisms
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri Aug 19 22:33:00 UTC 2022
Ben Gamari pushed to branch wip/exception-context at Glasgow Haskell Compiler / GHC
Commits:
696d35f8 by Ben Gamari at 2022-08-19T18:27:09-04:00
Mechanisms
- - - - -
293e0772 by Ben Gamari at 2022-08-19T18:29:51-04:00
base: Move PrimMVar to GHC.MVar
- - - - -
2d00c7af by Ben Gamari at 2022-08-19T18:32:06-04:00
Drop redundant boot files
- - - - -
7 changed files:
- libraries/base/GHC/Conc/Sync.hs
- libraries/base/GHC/Exception.hs
- libraries/base/GHC/Exception/Backtrace.hs
- − libraries/base/GHC/ExecutionStack.hs-boot
- libraries/base/GHC/IO.hs
- libraries/base/GHC/MVar.hs
- − libraries/base/GHC/Stack/CloneStack.hs-boot
Changes:
=====================================
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
=====================================
@@ -44,7 +44,7 @@ import GHC.OldList
import GHC.IO.Unsafe
import {-# SOURCE #-} GHC.Stack.CCS
import {-# SOURCE #-} GHC.Stack (prettyCallStackLines, prettyCallStack, prettySrcLoc)
-import GHC.Exception.Backtrace
+import {-# SOURCE #-} GHC.Exception.Backtrace (collectBacktraces)
import GHC.Exception.Context
import GHC.Exception.Type
=====================================
libraries/base/GHC/Exception/Backtrace.hs
=====================================
@@ -3,45 +3,55 @@
{-# LANGUAGE NamedFieldPuns #-}
module GHC.Exception.Backtrace
- ( BacktraceMechanism(..)
+ ( -- * 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 {-# 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
+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 a cost center stacktrace (only available when built with profiling)
+ = -- | collect cost-centre stack backtraces (only available when built with profiling)
CostCentreBacktraceMech
- | -- | use execution stack unwinding with given limit
- ExecutionStackBacktraceMech
+ | -- | collect backtraces from native execution stack unwinding
+ ExecutionStackBacktraceMech -- TODO: unwind limit?
| -- | collect backtraces from Info Table Provenance Entries
IPEBacktraceMech
- | -- | use 'HasCallStack'
+ | -- | 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
- mconcat `fmap` mapM collect
- [ CostCentreBacktraceMech
- , ExecutionStackBacktraceMech
- , IPEBacktraceMech
- , HasCallStackBacktraceMech
- ]
- where
- collect mech
- | True = collectBacktrace mech -- FIXME
- -- | otherwise = return mempty
+ mechs <- getEnabledBacktraceMechanisms
+ mconcat `fmap` mapM collectBacktrace mechs
data CostCentreBacktrace = CostCentreBacktrace [String]
=====================================
libraries/base/GHC/ExecutionStack.hs-boot deleted
=====================================
@@ -1,8 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module GHC.ExecutionStack where
-
-import GHC.Base
-
-showStackTrace :: IO (Maybe String)
-
=====================================
libraries/base/GHC/IO.hs
=====================================
@@ -48,9 +48,9 @@ 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.Exception.Backtrace ( collectBacktraces )
import {-# SOURCE #-} GHC.IO.Exception ( userError, IOError )
-- ---------------------------------------------------------------------------
=====================================
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/CloneStack.hs-boot deleted
=====================================
@@ -1,12 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module GHC.Stack.CloneStack where
-
-import GHC.Base
-
-data StackSnapshot
-data StackEntry
-
-cloneMyStack :: IO StackSnapshot
-decode :: StackSnapshot -> IO [StackEntry]
-prettyStackEntry :: StackEntry -> String
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e0998ccec48d57951228581c6090dbfb8ab5796f...2d00c7af4a4ac3251ccf1bdf2b2fa808b0de5255
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e0998ccec48d57951228581c6090dbfb8ab5796f...2d00c7af4a4ac3251ccf1bdf2b2fa808b0de5255
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/3de44011/attachment-0001.html>
More information about the ghc-commits
mailing list