diff --git a/libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs b/libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs index 017ecb28d225589bc0ea8aa69a1a10ebc436144a..e12d20bb674c2b125b7b7fe6c9af1b9dad29953f 100644 --- a/libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs +++ b/libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs @@ -125,12 +125,9 @@ import GHC.Internal.MVar import GHC.Internal.Ptr import GHC.Internal.Real ( fromIntegral ) import GHC.Internal.Show ( Show(..), showParen, showString ) -import GHC.Internal.Stable ( StablePtr(..) ) import GHC.Internal.Weak import GHC.Internal.Word -import GHC.Internal.Unsafe.Coerce ( unsafeCoerce# ) - infixr 0 `par`, `pseq` ----------------------------------------------------------------------------- @@ -671,20 +668,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 ----------------------------------------------------------------------------- diff --git a/libraries/ghc-internal/src/GHC/Internal/MVar.hs b/libraries/ghc-internal/src/GHC/Internal/MVar.hs index a4af4f061fd1f5b29de5eb265425dd71519f40da..d800263bc7e16ddf9941ca562cb447732895a8b3 100644 --- a/libraries/ghc-internal/src/GHC/Internal/MVar.hs +++ b/libraries/ghc-internal/src/GHC/Internal/MVar.hs @@ -30,9 +30,15 @@ module GHC.Internal.MVar ( , tryReadMVar , isEmptyMVar , addMVarFinalizer + + -- * PrimMVar + , PrimMVar + , newStablePtrPrimMVar ) where import GHC.Internal.Base +import GHC.Internal.Stable ( StablePtr(..) ) +import GHC.Internal.Unsafe.Coerce ( unsafeCoerce# ) data MVar a = MVar (MVar# RealWorld a) {- ^ @@ -183,3 +189,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 #) +