{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE Unsafe #-}
{-# OPTIONS_HADDOCK not-home #-}
module GHC.Conc.Sync
( ThreadId(..)
, showThreadId
, forkIO
, forkIOWithUnmask
, forkOn
, forkOnWithUnmask
, numCapabilities
, getNumCapabilities
, setNumCapabilities
, getNumProcessors
, numSparks
, childHandler
, myThreadId
, killThread
, throwTo
, par
, pseq
, runSparks
, yield
, labelThread
, mkWeakThreadId
, ThreadStatus(..), BlockReason(..)
, threadStatus
, threadCapability
, newStablePtrPrimMVar, PrimMVar
, setAllocationCounter
, getAllocationCounter
, enableAllocationLimit
, disableAllocationLimit
, STM(..)
, atomically
, retry
, orElse
, throwSTM
, catchSTM
, TVar(..)
, newTVar
, newTVarIO
, readTVar
, readTVarIO
, writeTVar
, unsafeIOToSTM
, withMVar
, modifyMVar_
, setUncaughtExceptionHandler
, getUncaughtExceptionHandler
, reportError, reportStackOverflow, reportHeapOverflow
, sharedCAF
) where
import Foreign
import Foreign.C
import Data.Typeable
import Data.Maybe
import GHC.Base
import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
import {-# SOURCE #-} GHC.IO.StdHandles ( stdout )
import GHC.Int
import GHC.IO
import GHC.IO.Encoding.UTF8
import GHC.IO.Exception
import GHC.Exception
import qualified GHC.Foreign
import GHC.IORef
import GHC.MVar
import GHC.Ptr
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`
data ThreadId = ThreadId ThreadId#
instance Show ThreadId where
showsPrec :: Int -> ThreadId -> ShowS
showsPrec Int
d ThreadId
t = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
>= Int
11) forall a b. (a -> b) -> a -> b
$
String -> ShowS
showString String
"ThreadId " forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d (ThreadId# -> CInt
getThreadId (ThreadId -> ThreadId#
id2TSO ThreadId
t))
showThreadId :: ThreadId -> String
showThreadId :: ThreadId -> String
showThreadId = forall a. Show a => a -> String
show
foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
id2TSO :: ThreadId -> ThreadId#
id2TSO :: ThreadId -> ThreadId#
id2TSO (ThreadId ThreadId#
t) = ThreadId#
t
foreign import ccall unsafe "eq_thread" eq_thread :: ThreadId# -> ThreadId# -> CBool
foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
instance Eq ThreadId where
ThreadId ThreadId#
t1 == :: ThreadId -> ThreadId -> Bool
== ThreadId ThreadId#
t2 = ThreadId# -> ThreadId# -> CBool
eq_thread ThreadId#
t1 ThreadId#
t2 forall a. Eq a => a -> a -> Bool
/= CBool
0
instance Ord ThreadId where
compare :: ThreadId -> ThreadId -> Ordering
compare (ThreadId ThreadId#
t1) (ThreadId ThreadId#
t2) = case ThreadId# -> ThreadId# -> CInt
cmp_thread ThreadId#
t1 ThreadId#
t2 of
-1 -> Ordering
LT
CInt
0 -> Ordering
EQ
CInt
_ -> Ordering
GT
setAllocationCounter :: Int64 -> IO ()
setAllocationCounter :: Int64 -> IO ()
setAllocationCounter (I64# Int#
i) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
case Int# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# Int#
i State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)
getAllocationCounter :: IO Int64
getAllocationCounter :: IO Int64
getAllocationCounter = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
case State# RealWorld -> (# State# RealWorld, Int# #)
getThreadAllocationCounter# State# RealWorld
s of (# State# RealWorld
s', Int#
ctr #) -> (# State# RealWorld
s', Int# -> Int64
I64# Int#
ctr #)
enableAllocationLimit :: IO ()
enableAllocationLimit :: IO ()
enableAllocationLimit = do
ThreadId ThreadId#
t <- IO ThreadId
myThreadId
ThreadId# -> IO ()
rts_enableThreadAllocationLimit ThreadId#
t
disableAllocationLimit :: IO ()
disableAllocationLimit :: IO ()
disableAllocationLimit = do
ThreadId ThreadId#
t <- IO ThreadId
myThreadId
ThreadId# -> IO ()
rts_disableThreadAllocationLimit ThreadId#
t
foreign import ccall unsafe "rts_enableThreadAllocationLimit"
rts_enableThreadAllocationLimit :: ThreadId# -> IO ()
foreign import ccall unsafe "rts_disableThreadAllocationLimit"
rts_disableThreadAllocationLimit :: ThreadId# -> IO ()
forkIO :: IO () -> IO ThreadId
forkIO :: IO () -> IO ThreadId
forkIO IO ()
action = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s ->
case (forall a.
a -> State# RealWorld -> (# State# RealWorld, ThreadId# #)
fork# IO ()
action_plus State# RealWorld
s) of (# State# RealWorld
s1, ThreadId#
tid #) -> (# State# RealWorld
s1, ThreadId# -> ThreadId
ThreadId ThreadId#
tid #)
where
action_plus :: IO ()
action_plus = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO ()
action SomeException -> IO ()
childHandler
forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask :: ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask (forall a. IO a -> IO a) -> IO ()
io = IO () -> IO ThreadId
forkIO ((forall a. IO a -> IO a) -> IO ()
io forall a. IO a -> IO a
unsafeUnmask)
forkOn :: Int -> IO () -> IO ThreadId
forkOn :: Int -> IO () -> IO ThreadId
forkOn (I# Int#
cpu) IO ()
action = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s ->
case (forall a.
Int# -> a -> State# RealWorld -> (# State# RealWorld, ThreadId# #)
forkOn# Int#
cpu IO ()
action_plus State# RealWorld
s) of (# State# RealWorld
s1, ThreadId#
tid #) -> (# State# RealWorld
s1, ThreadId# -> ThreadId
ThreadId ThreadId#
tid #)
where
action_plus :: IO ()
action_plus = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO ()
action SomeException -> IO ()
childHandler
forkOnWithUnmask :: Int -> ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
forkOnWithUnmask :: Int -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkOnWithUnmask Int
cpu (forall a. IO a -> IO a) -> IO ()
io = Int -> IO () -> IO ThreadId
forkOn Int
cpu ((forall a. IO a -> IO a) -> IO ()
io forall a. IO a -> IO a
unsafeUnmask)
numCapabilities :: Int
numCapabilities :: Int
numCapabilities = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ IO Int
getNumCapabilities
getNumCapabilities :: IO Int
getNumCapabilities :: IO Int
getNumCapabilities = do
CInt
n <- forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
enabled_capabilities
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
n)
setNumCapabilities :: Int -> IO ()
setNumCapabilities :: Int -> IO ()
setNumCapabilities Int
i
| Int
i forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. String -> IO a
failIO forall a b. (a -> b) -> a -> b
$ String
"setNumCapabilities: Capability count ("forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
iforall a. [a] -> [a] -> [a]
++String
") must be positive"
| Bool
otherwise = CUInt -> IO ()
c_setNumCapabilities (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
foreign import ccall safe "setNumCapabilities"
c_setNumCapabilities :: CUInt -> IO ()
getNumProcessors :: IO Int
getNumProcessors :: IO Int
getNumProcessors = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral IO CUInt
c_getNumberOfProcessors
foreign import ccall unsafe "getNumberOfProcessors"
c_getNumberOfProcessors :: IO CUInt
numSparks :: IO Int
numSparks :: IO Int
numSparks = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case forall d. State# d -> (# State# d, Int# #)
numSparks# State# RealWorld
s of (# State# RealWorld
s', Int#
n #) -> (# State# RealWorld
s', Int# -> Int
I# Int#
n #)
foreign import ccall "&enabled_capabilities" enabled_capabilities :: Ptr CInt
childHandler :: SomeException -> IO ()
childHandler :: SomeException -> IO ()
childHandler SomeException
err = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (SomeException -> IO ()
real_handler SomeException
err) SomeException -> IO ()
childHandler
real_handler :: SomeException -> IO ()
real_handler :: SomeException -> IO ()
real_handler SomeException
se
| Just BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just BlockedIndefinitelyOnSTM
BlockedIndefinitelyOnSTM <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just AsyncException
ThreadKilled <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just AsyncException
StackOverflow <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = IO ()
reportStackOverflow
| Bool
otherwise = SomeException -> IO ()
reportError SomeException
se
killThread :: ThreadId -> IO ()
killThread :: ThreadId -> IO ()
killThread ThreadId
tid = forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid AsyncException
ThreadKilled
throwTo :: Exception e => ThreadId -> e -> IO ()
throwTo :: forall e. Exception e => ThreadId -> e -> IO ()
throwTo (ThreadId ThreadId#
tid) e
ex = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s ->
case (forall a. ThreadId# -> a -> State# RealWorld -> State# RealWorld
killThread# ThreadId#
tid (forall e. Exception e => e -> SomeException
toException e
ex) State# RealWorld
s) of State# RealWorld
s1 -> (# State# RealWorld
s1, () #)
myThreadId :: IO ThreadId
myThreadId :: IO ThreadId
myThreadId = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
case (State# RealWorld -> (# State# RealWorld, ThreadId# #)
myThreadId# State# RealWorld
s) of (# State# RealWorld
s1, ThreadId#
tid #) -> (# State# RealWorld
s1, ThreadId# -> ThreadId
ThreadId ThreadId#
tid #)
yield :: IO ()
yield :: IO ()
yield = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
case (State# RealWorld -> State# RealWorld
yield# State# RealWorld
s) of State# RealWorld
s1 -> (# State# RealWorld
s1, () #)
labelThread :: ThreadId -> String -> IO ()
labelThread :: ThreadId -> String -> IO ()
labelThread (ThreadId ThreadId#
t) String
str =
forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
GHC.Foreign.withCString TextEncoding
utf8 String
str forall a b. (a -> b) -> a -> b
$ \(Ptr Addr#
p) ->
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s ->
case ThreadId# -> Addr# -> State# RealWorld -> State# RealWorld
labelThread# ThreadId#
t Addr#
p State# RealWorld
s of State# RealWorld
s1 -> (# State# RealWorld
s1, () #)
{-# INLINE pseq #-}
pseq :: a -> b -> b
pseq :: forall a b. a -> b -> b
pseq a
x b
y = a
x seq :: forall a b. a -> b -> b
`seq` forall a. a -> a
lazy b
y
{-# INLINE par #-}
par :: a -> b -> b
par :: forall a b. a -> b -> b
par a
x b
y = case (forall a. a -> Int#
par# a
x) of { Int#
_ -> forall a. a -> a
lazy b
y }
runSparks :: IO ()
runSparks :: IO ()
runSparks = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall {d}. State# d -> (# State# d, () #)
loop
where loop :: State# d -> (# State# d, () #)
loop State# d
s = case forall d a. State# d -> (# State# d, Int#, a #)
getSpark# State# d
s of
(# State# d
s', Int#
n, Any
p #) ->
if Int# -> Bool
isTrue# (Int#
n Int# -> Int# -> Int#
==# Int#
0#)
then (# State# d
s', () #)
else Any
p seq :: forall a b. a -> b -> b
`seq` State# d -> (# State# d, () #)
loop State# d
s'
data BlockReason
= BlockedOnMVar
| BlockedOnBlackHole
| BlockedOnException
| BlockedOnSTM
| BlockedOnForeignCall
| BlockedOnOther
deriving ( BlockReason -> BlockReason -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockReason -> BlockReason -> Bool
$c/= :: BlockReason -> BlockReason -> Bool
== :: BlockReason -> BlockReason -> Bool
$c== :: BlockReason -> BlockReason -> Bool
Eq
, Eq BlockReason
BlockReason -> BlockReason -> Bool
BlockReason -> BlockReason -> Ordering
BlockReason -> BlockReason -> BlockReason
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BlockReason -> BlockReason -> BlockReason
$cmin :: BlockReason -> BlockReason -> BlockReason
max :: BlockReason -> BlockReason -> BlockReason
$cmax :: BlockReason -> BlockReason -> BlockReason
>= :: BlockReason -> BlockReason -> Bool
$c>= :: BlockReason -> BlockReason -> Bool
> :: BlockReason -> BlockReason -> Bool
$c> :: BlockReason -> BlockReason -> Bool
<= :: BlockReason -> BlockReason -> Bool
$c<= :: BlockReason -> BlockReason -> Bool
< :: BlockReason -> BlockReason -> Bool
$c< :: BlockReason -> BlockReason -> Bool
compare :: BlockReason -> BlockReason -> Ordering
$ccompare :: BlockReason -> BlockReason -> Ordering
Ord
, Int -> BlockReason -> ShowS
[BlockReason] -> ShowS
BlockReason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockReason] -> ShowS
$cshowList :: [BlockReason] -> ShowS
show :: BlockReason -> String
$cshow :: BlockReason -> String
showsPrec :: Int -> BlockReason -> ShowS
$cshowsPrec :: Int -> BlockReason -> ShowS
Show
)
data ThreadStatus
= ThreadRunning
| ThreadFinished
| ThreadBlocked BlockReason
| ThreadDied
deriving ( ThreadStatus -> ThreadStatus -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThreadStatus -> ThreadStatus -> Bool
$c/= :: ThreadStatus -> ThreadStatus -> Bool
== :: ThreadStatus -> ThreadStatus -> Bool
$c== :: ThreadStatus -> ThreadStatus -> Bool
Eq
, Eq ThreadStatus
ThreadStatus -> ThreadStatus -> Bool
ThreadStatus -> ThreadStatus -> Ordering
ThreadStatus -> ThreadStatus -> ThreadStatus
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ThreadStatus -> ThreadStatus -> ThreadStatus
$cmin :: ThreadStatus -> ThreadStatus -> ThreadStatus
max :: ThreadStatus -> ThreadStatus -> ThreadStatus
$cmax :: ThreadStatus -> ThreadStatus -> ThreadStatus
>= :: ThreadStatus -> ThreadStatus -> Bool
$c>= :: ThreadStatus -> ThreadStatus -> Bool
> :: ThreadStatus -> ThreadStatus -> Bool
$c> :: ThreadStatus -> ThreadStatus -> Bool
<= :: ThreadStatus -> ThreadStatus -> Bool
$c<= :: ThreadStatus -> ThreadStatus -> Bool
< :: ThreadStatus -> ThreadStatus -> Bool
$c< :: ThreadStatus -> ThreadStatus -> Bool
compare :: ThreadStatus -> ThreadStatus -> Ordering
$ccompare :: ThreadStatus -> ThreadStatus -> Ordering
Ord
, Int -> ThreadStatus -> ShowS
[ThreadStatus] -> ShowS
ThreadStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThreadStatus] -> ShowS
$cshowList :: [ThreadStatus] -> ShowS
show :: ThreadStatus -> String
$cshow :: ThreadStatus -> String
showsPrec :: Int -> ThreadStatus -> ShowS
$cshowsPrec :: Int -> ThreadStatus -> ShowS
Show
)
threadStatus :: ThreadId -> IO ThreadStatus
threadStatus :: ThreadId -> IO ThreadStatus
threadStatus (ThreadId ThreadId#
t) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
case ThreadId#
-> State# RealWorld -> (# State# RealWorld, Int#, Int#, Int# #)
threadStatus# ThreadId#
t State# RealWorld
s of
(# State# RealWorld
s', Int#
stat, Int#
_cap, Int#
_locked #) -> (# State# RealWorld
s', forall {a}. (Eq a, Num a) => a -> ThreadStatus
mk_stat (Int# -> Int
I# Int#
stat) #)
where
mk_stat :: a -> ThreadStatus
mk_stat a
0 = ThreadStatus
ThreadRunning
mk_stat a
1 = BlockReason -> ThreadStatus
ThreadBlocked BlockReason
BlockedOnMVar
mk_stat a
2 = BlockReason -> ThreadStatus
ThreadBlocked BlockReason
BlockedOnBlackHole
mk_stat a
6 = BlockReason -> ThreadStatus
ThreadBlocked BlockReason
BlockedOnSTM
mk_stat a
10 = BlockReason -> ThreadStatus
ThreadBlocked BlockReason
BlockedOnForeignCall
mk_stat a
11 = BlockReason -> ThreadStatus
ThreadBlocked BlockReason
BlockedOnForeignCall
mk_stat a
12 = BlockReason -> ThreadStatus
ThreadBlocked BlockReason
BlockedOnException
mk_stat a
14 = BlockReason -> ThreadStatus
ThreadBlocked BlockReason
BlockedOnMVar
mk_stat a
16 = ThreadStatus
ThreadFinished
mk_stat a
17 = ThreadStatus
ThreadDied
mk_stat a
_ = BlockReason -> ThreadStatus
ThreadBlocked BlockReason
BlockedOnOther
threadCapability :: ThreadId -> IO (Int, Bool)
threadCapability :: ThreadId -> IO (Int, Bool)
threadCapability (ThreadId ThreadId#
t) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
case ThreadId#
-> State# RealWorld -> (# State# RealWorld, Int#, Int#, Int# #)
threadStatus# ThreadId#
t State# RealWorld
s of
(# State# RealWorld
s', Int#
_, Int#
cap#, Int#
locked# #) -> (# State# RealWorld
s', (Int# -> Int
I# Int#
cap#, Int# -> Bool
isTrue# (Int#
locked# Int# -> Int# -> Int#
/=# Int#
0#)) #)
mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
mkWeakThreadId t :: ThreadId
t@(ThreadId ThreadId#
t#) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
case mkWeakNoFinalizer# :: forall a b.
a -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
mkWeakNoFinalizer# ThreadId#
t# ThreadId
t State# RealWorld
s of
(# State# RealWorld
s1, Weak# ThreadId
w #) -> (# State# RealWorld
s1, forall v. Weak# v -> Weak v
Weak Weak# ThreadId
w #)
data PrimMVar
newStablePtrPrimMVar :: MVar () -> IO (StablePtr PrimMVar)
newStablePtrPrimMVar :: MVar () -> IO (StablePtr PrimMVar)
newStablePtrPrimMVar (MVar MVar# RealWorld ()
m) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
case forall a.
a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #)
makeStablePtr# (forall a b. a -> b
unsafeCoerce# MVar# RealWorld ()
m :: PrimMVar) State# RealWorld
s0 of
(# State# RealWorld
s1, StablePtr# PrimMVar
sp #) -> (# State# RealWorld
s1, forall a. StablePtr# a -> StablePtr a
StablePtr StablePtr# PrimMVar
sp #)
newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
unSTM :: forall a. STM a -> State# RealWorld -> (# State# RealWorld, a #)
unSTM (STM State# RealWorld -> (# State# RealWorld, a #)
a) = State# RealWorld -> (# State# RealWorld, a #)
a
instance Functor STM where
fmap :: forall a b. (a -> b) -> STM a -> STM b
fmap a -> b
f STM a
x = STM a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
instance Applicative STM where
{-# INLINE pure #-}
{-# INLINE (*>) #-}
{-# INLINE liftA2 #-}
pure :: forall a. a -> STM a
pure a
x = forall a. a -> STM a
returnSTM a
x
<*> :: forall a b. STM (a -> b) -> STM a -> STM b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
liftA2 :: forall a b c. (a -> b -> c) -> STM a -> STM b -> STM c
liftA2 = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2
STM a
m *> :: forall a b. STM a -> STM b -> STM b
*> STM b
k = forall a b. STM a -> STM b -> STM b
thenSTM STM a
m STM b
k
instance Monad STM where
{-# INLINE (>>=) #-}
STM a
m >>= :: forall a b. STM a -> (a -> STM b) -> STM b
>>= a -> STM b
k = forall a b. STM a -> (a -> STM b) -> STM b
bindSTM STM a
m a -> STM b
k
>> :: forall a b. STM a -> STM b -> STM b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
bindSTM :: STM a -> (a -> STM b) -> STM b
bindSTM :: forall a b. STM a -> (a -> STM b) -> STM b
bindSTM (STM State# RealWorld -> (# State# RealWorld, a #)
m) a -> STM b
k = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ( \State# RealWorld
s ->
case State# RealWorld -> (# State# RealWorld, a #)
m State# RealWorld
s of
(# State# RealWorld
new_s, a
a #) -> forall a. STM a -> State# RealWorld -> (# State# RealWorld, a #)
unSTM (a -> STM b
k a
a) State# RealWorld
new_s
)
thenSTM :: STM a -> STM b -> STM b
thenSTM :: forall a b. STM a -> STM b -> STM b
thenSTM (STM State# RealWorld -> (# State# RealWorld, a #)
m) STM b
k = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ( \State# RealWorld
s ->
case State# RealWorld -> (# State# RealWorld, a #)
m State# RealWorld
s of
(# State# RealWorld
new_s, a
_ #) -> forall a. STM a -> State# RealWorld -> (# State# RealWorld, a #)
unSTM STM b
k State# RealWorld
new_s
)
returnSTM :: a -> STM a
returnSTM :: forall a. a -> STM a
returnSTM a
x = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM (\State# RealWorld
s -> (# State# RealWorld
s, a
x #))
instance Alternative STM where
empty :: forall a. STM a
empty = forall a. STM a
retry
<|> :: forall a. STM a -> STM a -> STM a
(<|>) = forall a. STM a -> STM a -> STM a
orElse
instance MonadPlus STM
unsafeIOToSTM :: IO a -> STM a
unsafeIOToSTM :: forall a. IO a -> STM a
unsafeIOToSTM (IO State# RealWorld -> (# State# RealWorld, a #)
m) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM State# RealWorld -> (# State# RealWorld, a #)
m
atomically :: STM a -> IO a
atomically :: forall a. STM a -> IO a
atomically (STM State# RealWorld -> (# State# RealWorld, a #)
m) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> (forall a.
(State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld -> (# State# RealWorld, a #)
atomically# State# RealWorld -> (# State# RealWorld, a #)
m) State# RealWorld
s )
retry :: STM a
retry :: forall a. STM a
retry = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# -> forall a. State# RealWorld -> (# State# RealWorld, a #)
retry# State# RealWorld
s#
orElse :: STM a -> STM a -> STM a
orElse :: forall a. STM a -> STM a -> STM a
orElse (STM State# RealWorld -> (# State# RealWorld, a #)
m) STM a
e = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> forall a.
(State# RealWorld -> (# State# RealWorld, a #))
-> (State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld
-> (# State# RealWorld, a #)
catchRetry# State# RealWorld -> (# State# RealWorld, a #)
m (forall a. STM a -> State# RealWorld -> (# State# RealWorld, a #)
unSTM STM a
e) State# RealWorld
s
throwSTM :: Exception e => e -> STM a
throwSTM :: forall e a. Exception e => e -> STM a
throwSTM e
e = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM forall a b. (a -> b) -> a -> b
$ forall a b. a -> State# RealWorld -> (# State# RealWorld, b #)
raiseIO# (forall e. Exception e => e -> SomeException
toException e
e)
catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
catchSTM :: forall e a. Exception e => STM a -> (e -> STM a) -> STM a
catchSTM (STM State# RealWorld -> (# State# RealWorld, a #)
m) e -> STM a
handler = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM forall a b. (a -> b) -> a -> b
$ forall a b.
(State# RealWorld -> (# State# RealWorld, a #))
-> (b -> State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld
-> (# State# RealWorld, a #)
catchSTM# State# RealWorld -> (# State# RealWorld, a #)
m SomeException -> State# RealWorld -> (# State# RealWorld, a #)
handler'
where
handler' :: SomeException -> State# RealWorld -> (# State# RealWorld, a #)
handler' SomeException
e = case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just e
e' -> forall a. STM a -> State# RealWorld -> (# State# RealWorld, a #)
unSTM (e -> STM a
handler e
e')
Maybe e
Nothing -> forall a b. a -> State# RealWorld -> (# State# RealWorld, b #)
raiseIO# SomeException
e
data TVar a = TVar (TVar# RealWorld a)
instance Eq (TVar a) where
(TVar TVar# RealWorld a
tvar1#) == :: TVar a -> TVar a -> Bool
== (TVar TVar# RealWorld a
tvar2#) = Int# -> Bool
isTrue# (forall d a. TVar# d a -> TVar# d a -> Int#
sameTVar# TVar# RealWorld a
tvar1# TVar# RealWorld a
tvar2#)
newTVar :: a -> STM (TVar a)
newTVar :: forall a. a -> STM (TVar a)
newTVar a
val = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
case forall a d. a -> State# d -> (# State# d, TVar# d a #)
newTVar# a
val State# RealWorld
s1# of
(# State# RealWorld
s2#, TVar# RealWorld a
tvar# #) -> (# State# RealWorld
s2#, forall a. TVar# RealWorld a -> TVar a
TVar TVar# RealWorld a
tvar# #)
newTVarIO :: a -> IO (TVar a)
newTVarIO :: forall a. a -> IO (TVar a)
newTVarIO a
val = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
case forall a d. a -> State# d -> (# State# d, TVar# d a #)
newTVar# a
val State# RealWorld
s1# of
(# State# RealWorld
s2#, TVar# RealWorld a
tvar# #) -> (# State# RealWorld
s2#, forall a. TVar# RealWorld a -> TVar a
TVar TVar# RealWorld a
tvar# #)
readTVarIO :: TVar a -> IO a
readTVarIO :: forall a. TVar a -> IO a
readTVarIO (TVar TVar# RealWorld a
tvar#) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# -> forall d a. TVar# d a -> State# d -> (# State# d, a #)
readTVarIO# TVar# RealWorld a
tvar# State# RealWorld
s#
readTVar :: TVar a -> STM a
readTVar :: forall a. TVar a -> STM a
readTVar (TVar TVar# RealWorld a
tvar#) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# -> forall d a. TVar# d a -> State# d -> (# State# d, a #)
readTVar# TVar# RealWorld a
tvar# State# RealWorld
s#
writeTVar :: TVar a -> a -> STM ()
writeTVar :: forall a. TVar a -> a -> STM ()
writeTVar (TVar TVar# RealWorld a
tvar#) a
val = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
case forall d a. TVar# d a -> a -> State# d -> State# d
writeTVar# TVar# RealWorld a
tvar# a
val State# RealWorld
s1# of
State# RealWorld
s2# -> (# State# RealWorld
s2#, () #)
withMVar :: MVar a -> (a -> IO b) -> IO b
withMVar :: forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar a
m a -> IO b
io =
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
a
a <- forall a. MVar a -> IO a
takeMVar MVar a
m
b
b <- forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a
catchAny (forall a. IO a -> IO a
restore (a -> IO b
io a
a))
(\e
e -> do forall a. MVar a -> a -> IO ()
putMVar MVar a
m a
a; forall a e. Exception e => e -> a
throw e
e)
forall a. MVar a -> a -> IO ()
putMVar MVar a
m a
a
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
modifyMVar_ :: forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar a
m a -> IO a
io =
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
a
a <- forall a. MVar a -> IO a
takeMVar MVar a
m
a
a' <- forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a
catchAny (forall a. IO a -> IO a
restore (a -> IO a
io a
a))
(\e
e -> do forall a. MVar a -> a -> IO ()
putMVar MVar a
m a
a; forall a e. Exception e => e -> a
throw e
e)
forall a. MVar a -> a -> IO ()
putMVar MVar a
m a
a'
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF :: forall a. a -> (Ptr a -> IO (Ptr a)) -> IO a
sharedCAF a
a Ptr a -> IO (Ptr a)
get_or_set =
forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
StablePtr a
stable_ref <- forall a. a -> IO (StablePtr a)
newStablePtr a
a
let ref :: Ptr b
ref = forall a b. Ptr a -> Ptr b
castPtr (forall a. StablePtr a -> Ptr ()
castStablePtrToPtr StablePtr a
stable_ref)
Ptr a
ref2 <- Ptr a -> IO (Ptr a)
get_or_set forall {b}. Ptr b
ref
if forall {b}. Ptr b
refforall a. Eq a => a -> a -> Bool
==Ptr a
ref2
then forall (m :: * -> *) a. Monad m => a -> m a
return a
a
else do forall a. StablePtr a -> IO ()
freeStablePtr StablePtr a
stable_ref
forall a. StablePtr a -> IO a
deRefStablePtr (forall a. Ptr () -> StablePtr a
castPtrToStablePtr (forall a b. Ptr a -> Ptr b
castPtr Ptr a
ref2))
reportStackOverflow :: IO ()
reportStackOverflow :: IO ()
reportStackOverflow = do
ThreadId ThreadId#
tid <- IO ThreadId
myThreadId
ThreadId# -> IO ()
c_reportStackOverflow ThreadId#
tid
reportError :: SomeException -> IO ()
reportError :: SomeException -> IO ()
reportError SomeException
ex = do
SomeException -> IO ()
handler <- IO (SomeException -> IO ())
getUncaughtExceptionHandler
SomeException -> IO ()
handler SomeException
ex
foreign import ccall unsafe "reportStackOverflow"
c_reportStackOverflow :: ThreadId# -> IO ()
foreign import ccall unsafe "reportHeapOverflow"
reportHeapOverflow :: IO ()
{-# NOINLINE uncaughtExceptionHandler #-}
uncaughtExceptionHandler :: IORef (SomeException -> IO ())
uncaughtExceptionHandler :: IORef (SomeException -> IO ())
uncaughtExceptionHandler = forall a. IO a -> a
unsafePerformIO (forall a. a -> IO (IORef a)
newIORef SomeException -> IO ()
defaultHandler)
where
defaultHandler :: SomeException -> IO ()
defaultHandler :: SomeException -> IO ()
defaultHandler se :: SomeException
se@(SomeException e
ex) = do
(Handle -> IO ()
hFlush Handle
stdout) forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a
`catchAny` (\ e
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
let msg :: String
msg = case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
ex of
Just Deadlock
Deadlock -> String
"no threads to run: infinite loop or deadlock?"
Maybe Deadlock
_ -> forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 SomeException
se String
""
forall a. String -> (CString -> IO a) -> IO a
withCString String
"%s" forall a b. (a -> b) -> a -> b
$ \CString
cfmt ->
forall a. String -> (CString -> IO a) -> IO a
withCString String
msg forall a b. (a -> b) -> a -> b
$ \CString
cmsg ->
CString -> CString -> IO ()
errorBelch CString
cfmt CString
cmsg
foreign import ccall unsafe "HsBase.h errorBelch2"
errorBelch :: CString -> CString -> IO ()
setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
setUncaughtExceptionHandler = forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
uncaughtExceptionHandler
getUncaughtExceptionHandler :: IO (SomeException -> IO ())
getUncaughtExceptionHandler :: IO (SomeException -> IO ())
getUncaughtExceptionHandler = forall a. IORef a -> IO a
readIORef IORef (SomeException -> IO ())
uncaughtExceptionHandler