Home - News ( United States | United Kingdom | Italy | Germany ) - Football scores

Showing content from http://hackage.haskell.org/package/ghc-internal-9.1201.0/docs/src/GHC.Internal.Conc.Sync.html below:

{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE Unsafe #-}

{-# OPTIONS_HADDOCK not-home #-}





















module GHC.Internal.Conc.Sync
        (
        
          ThreadId(..)
        , fromThreadId
        , showThreadId
        , myThreadId
        , killThread
        , throwTo
        , yield
        , labelThread
        , labelThreadByteArray#
        , mkWeakThreadId
        
        , listThreads
        , threadLabel
        , ThreadStatus(..), BlockReason(..)
        , threadStatus
        , threadCapability

        
        , forkIO
        , forkIOWithUnmask
        , forkOn
        , forkOnWithUnmask

        
        , numCapabilities
        , getNumCapabilities
        , setNumCapabilities
        , getNumProcessors

        
        , numSparks
        , childHandler
        , par
        , pseq
        , runSparks

        
        , 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 GHC.Internal.Foreign.C.Types
import GHC.Internal.Foreign.C.String
import GHC.Internal.Foreign.Storable
import GHC.Internal.Foreign.StablePtr

import GHC.Internal.Base
import {-# SOURCE #-} GHC.Internal.IO.Handle ( hFlush )
import {-# SOURCE #-} GHC.Internal.IO.StdHandles ( stdout )
import GHC.Internal.Encoding.UTF8
import GHC.Internal.Int
import GHC.Internal.IO
import GHC.Internal.IO.Exception
import GHC.Internal.Exception
import GHC.Internal.IORef
import GHC.Internal.MVar
import GHC.Internal.Ptr
import GHC.Internal.Real         ( fromIntegral )
import GHC.Internal.Show         ( Show(..), showParen, showString )
import GHC.Internal.Weak
import GHC.Internal.Word

infixr 0 `par`, `pseq`





data ThreadId = ThreadId ThreadId#






fromThreadId :: ThreadId -> Word64
fromThreadId :: ThreadId -> Word64
fromThreadId ThreadId
tid = CULLong -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CULLong -> Word64) -> CULLong -> Word64
forall a b. (a -> b) -> a -> b
$ ThreadId# -> CULLong
getThreadId (ThreadId -> ThreadId#
id2TSO ThreadId
tid)


instance Show ThreadId where
   showsPrec :: Int -> ThreadId -> ShowS
showsPrec Int
d ThreadId
t = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"ThreadId " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        Int -> Word64 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d (ThreadId -> Word64
fromThreadId ThreadId
t)

showThreadId :: ThreadId -> String
showThreadId :: ThreadId -> String
showThreadId = ThreadId -> String
forall a. Show a => a -> String
show

foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CULLong

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 CBool -> CBool -> Bool
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# Int64#
i) = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case Int64# -> State# RealWorld -> State# RealWorld
setThreadAllocationCounter# Int64#
i State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)





getAllocationCounter :: IO Int64
getAllocationCounter :: IO Int64
getAllocationCounter = (State# RealWorld -> (# State# RealWorld, Int64 #)) -> IO Int64
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Int64 #)) -> IO Int64)
-> (State# RealWorld -> (# State# RealWorld, Int64 #)) -> IO Int64
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case State# RealWorld -> (# State# RealWorld, Int64# #)
getThreadAllocationCounter# State# RealWorld
s of (# State# RealWorld
s', Int64#
ctr #) -> (# State# RealWorld
s', Int64# -> Int64
I64# Int64#
ctr #)























enableAllocationLimit :: IO ()
enableAllocationLimit :: IO ()
enableAllocationLimit = do
  ThreadId t <- IO ThreadId
myThreadId
  rts_enableThreadAllocationLimit t




disableAllocationLimit :: IO ()
disableAllocationLimit :: IO ()
disableAllocationLimit = do
  ThreadId t <- IO ThreadId
myThreadId
  rts_disableThreadAllocationLimit 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 = (State# RealWorld -> (# State# RealWorld, ThreadId #))
-> IO ThreadId
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, ThreadId #))
 -> IO ThreadId)
-> (State# RealWorld -> (# State# RealWorld, ThreadId #))
-> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s ->
   case ((State# RealWorld -> (# State# RealWorld, () #))
-> State# RealWorld -> (# State# RealWorld, ThreadId# #)
forall a.
(State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld -> (# State# RealWorld, ThreadId# #)
fork# (IO () -> State# RealWorld -> (# State# RealWorld, () #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO 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 = IO () -> (SomeException -> IO ()) -> IO ()
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 IO a -> IO a
forall a. IO a -> IO a
unsafeUnmask)


forkOn :: Int -> IO () -> IO ThreadId
forkOn :: Int -> IO () -> IO ThreadId
forkOn (I# Int#
cpu) IO ()
action = (State# RealWorld -> (# State# RealWorld, ThreadId #))
-> IO ThreadId
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, ThreadId #))
 -> IO ThreadId)
-> (State# RealWorld -> (# State# RealWorld, ThreadId #))
-> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s ->
   case (Int#
-> (State# RealWorld -> (# State# RealWorld, () #))
-> State# RealWorld
-> (# State# RealWorld, ThreadId# #)
forall a.
Int#
-> (State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld
-> (# State# RealWorld, ThreadId# #)
forkOn# Int#
cpu (IO () -> State# RealWorld -> (# State# RealWorld, () #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO 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 = IO () -> (SomeException -> IO ()) -> IO ()
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 IO a -> IO a
forall a. IO a -> IO a
unsafeUnmask)









numCapabilities :: Int
numCapabilities :: Int
numCapabilities = IO Int -> Int
forall a. IO a -> a
unsafePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$ IO Int
getNumCapabilities


getNumCapabilities :: IO Int
getNumCapabilities :: IO Int
getNumCapabilities = do
   n <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
enabled_capabilities
   return (fromIntegral n)


setNumCapabilities :: Int -> IO ()
setNumCapabilities :: Int -> IO ()
setNumCapabilities Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = String -> IO ()
forall a. String -> IO a
failIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"setNumCapabilities: Capability count ("String -> ShowS
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
iString -> ShowS
forall a. [a] -> [a] -> [a]
++String
") must be positive"
  | Bool
otherwise = CUInt -> IO ()
c_setNumCapabilities (Int -> CUInt
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 = (CUInt -> Int) -> IO CUInt -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CUInt -> Int
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 = (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int)
-> (State# RealWorld -> (# State# RealWorld, Int #)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case State# RealWorld -> (# State# RealWorld, Int# #)
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 = IO () -> (SomeException -> IO ()) -> IO ()
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 <- SomeException -> Maybe BlockedIndefinitelyOnMVar
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se  =  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Just BlockedIndefinitelyOnSTM
BlockedIndefinitelyOnSTM  <- SomeException -> Maybe BlockedIndefinitelyOnSTM
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se  =  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Just AsyncException
ThreadKilled              <- SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se  =  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Just AsyncException
StackOverflow             <- SomeException -> Maybe AsyncException
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 = ThreadId -> AsyncException -> IO ()
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 = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ State# RealWorld
s ->
   case (ThreadId# -> SomeException -> State# RealWorld -> State# RealWorld
forall a. ThreadId# -> a -> State# RealWorld -> State# RealWorld
killThread# ThreadId#
tid (e -> SomeException
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 = (State# RealWorld -> (# State# RealWorld, ThreadId #))
-> IO ThreadId
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, ThreadId #))
 -> IO ThreadId)
-> (State# RealWorld -> (# State# RealWorld, ThreadId #))
-> IO ThreadId
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 = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> 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
t String
str =
    ThreadId -> ByteArray# -> IO ()
labelThreadByteArray# ThreadId
t (String -> ByteArray#
utf8EncodeByteArray# String
str)





labelThreadByteArray# :: ThreadId -> ByteArray# -> IO ()
labelThreadByteArray# :: ThreadId -> ByteArray# -> IO ()
labelThreadByteArray# (ThreadId ThreadId#
t) ByteArray#
str =
    (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case ThreadId# -> ByteArray# -> State# RealWorld -> State# RealWorld
labelThread# ThreadId#
t ByteArray#
str 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 a -> b -> b
forall a b. a -> b -> b
`seq` b -> b
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 (a -> Int#
forall a. a -> Int#
par# a
x) of { Int#
_ -> b -> b
forall a. a -> a
lazy b
y }


runSparks :: IO ()
runSparks :: IO ()
runSparks = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO State# RealWorld -> (# State# RealWorld, () #)
forall {d}. State# d -> (# State# d, () #)
loop
  where loop :: State# d -> (# State# d, () #)
loop State# d
s = case State# d -> (# State# d, Int#, ZonkAny 0 #)
forall d a. State# d -> (# State# d, Int#, a #)
getSpark# State# d
s of
                   (# State# d
s', Int#
n, ZonkAny 0
p #) ->
                      if Int# -> Bool
isTrue# (Int#
n Int# -> Int# -> Int#
==# Int#
0#)
                      then (# State# d
s', () #)
                      else ZonkAny 0
p ZonkAny 0 -> (# State# d, () #) -> (# State# d, () #)
forall a b. a -> b -> b
`seq` State# d -> (# State# d, () #)
loop State# d
s'




listThreads :: IO [ThreadId]
listThreads :: IO [ThreadId]
listThreads = (State# RealWorld -> (# State# RealWorld, [ThreadId] #))
-> IO [ThreadId]
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, [ThreadId] #))
 -> IO [ThreadId])
-> (State# RealWorld -> (# State# RealWorld, [ThreadId] #))
-> IO [ThreadId]
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case State# RealWorld -> (# State# RealWorld, Array# ThreadId# #)
listThreads# State# RealWorld
s of
      (# State# RealWorld
s', Array# ThreadId#
arr #) ->
        (# State# RealWorld
s', (ThreadId# -> ThreadId) -> Array# ThreadId# -> [ThreadId]
forall (a :: UnliftedType) b. (a -> b) -> Array# a -> [b]
mapListArrayUnlifted ThreadId# -> ThreadId
ThreadId Array# ThreadId#
arr #)

mapListArrayUnlifted :: forall (a :: TYPE UnliftedRep) b. (a -> b) -> Array# a -> [b]
mapListArrayUnlifted :: forall (a :: UnliftedType) b. (a -> b) -> Array# a -> [b]
mapListArrayUnlifted a -> b
f Array# a
arr = Int# -> [b]
go Int#
0#
  where
    sz :: Int#
sz = Array# a -> Int#
forall a. Array# a -> Int#
sizeofArray# Array# a
arr
    go :: Int# -> [b]
go Int#
i#
      | Int# -> Bool
isTrue# (Int#
i# Int# -> Int# -> Int#
==# Int#
sz) = []
      | Bool
otherwise = case Array# a -> Int# -> (# a #)
forall a. Array# a -> Int# -> (# a #)
indexArray# Array# a
arr Int#
i# of
                      (# a
x #) -> a -> b
f a
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: Int# -> [b]
go (Int#
i# Int# -> Int# -> Int#
+# Int#
1#)
{-# NOINLINE mapListArrayUnlifted #-}

data BlockReason
  = BlockedOnMVar
        
  
  | BlockedOnBlackHole
        
  | BlockedOnException
        
  | BlockedOnSTM
        
  | BlockedOnForeignCall
        
  | BlockedOnOther
        
        
        
  deriving ( BlockReason -> BlockReason -> Bool
(BlockReason -> BlockReason -> Bool)
-> (BlockReason -> BlockReason -> Bool) -> Eq BlockReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockReason -> BlockReason -> Bool
== :: BlockReason -> BlockReason -> Bool
$c/= :: BlockReason -> BlockReason -> Bool
/= :: BlockReason -> BlockReason -> Bool
Eq   
           , Eq BlockReason Eq BlockReason => (BlockReason -> BlockReason -> Ordering) -> (BlockReason -> BlockReason -> Bool) -> (BlockReason -> BlockReason -> Bool) -> (BlockReason -> BlockReason -> Bool) -> (BlockReason -> BlockReason -> Bool) -> (BlockReason -> BlockReason -> BlockReason) -> (BlockReason -> BlockReason -> BlockReason) -> Ord 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 $ccompare :: BlockReason -> BlockReason -> Ordering compare :: BlockReason -> BlockReason -> Ordering $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 >= :: BlockReason -> BlockReason -> Bool $cmax :: BlockReason -> BlockReason -> BlockReason max :: BlockReason -> BlockReason -> BlockReason $cmin :: BlockReason -> BlockReason -> BlockReason min :: BlockReason -> BlockReason -> BlockReason Ord  
           , Int -> BlockReason -> ShowS
[BlockReason] -> ShowS
BlockReason -> String
(Int -> BlockReason -> ShowS)
-> (BlockReason -> String)
-> ([BlockReason] -> ShowS)
-> Show BlockReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockReason -> ShowS
showsPrec :: Int -> BlockReason -> ShowS
$cshow :: BlockReason -> String
show :: BlockReason -> String
$cshowList :: [BlockReason] -> ShowS
showList :: [BlockReason] -> ShowS
Show 
           )


data ThreadStatus
  = ThreadRunning
        
  | ThreadFinished
        
  | ThreadBlocked  BlockReason
        
  | ThreadDied
        
  deriving ( ThreadStatus -> ThreadStatus -> Bool
(ThreadStatus -> ThreadStatus -> Bool)
-> (ThreadStatus -> ThreadStatus -> Bool) -> Eq ThreadStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThreadStatus -> ThreadStatus -> Bool
== :: ThreadStatus -> ThreadStatus -> Bool
$c/= :: ThreadStatus -> ThreadStatus -> Bool
/= :: ThreadStatus -> ThreadStatus -> Bool
Eq   
           , Eq ThreadStatus Eq ThreadStatus => (ThreadStatus -> ThreadStatus -> Ordering) -> (ThreadStatus -> ThreadStatus -> Bool) -> (ThreadStatus -> ThreadStatus -> Bool) -> (ThreadStatus -> ThreadStatus -> Bool) -> (ThreadStatus -> ThreadStatus -> Bool) -> (ThreadStatus -> ThreadStatus -> ThreadStatus) -> (ThreadStatus -> ThreadStatus -> ThreadStatus) -> Ord 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 $ccompare :: ThreadStatus -> ThreadStatus -> Ordering compare :: ThreadStatus -> ThreadStatus -> Ordering $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 >= :: ThreadStatus -> ThreadStatus -> Bool $cmax :: ThreadStatus -> ThreadStatus -> ThreadStatus max :: ThreadStatus -> ThreadStatus -> ThreadStatus $cmin :: ThreadStatus -> ThreadStatus -> ThreadStatus min :: ThreadStatus -> ThreadStatus -> ThreadStatus Ord  
           , Int -> ThreadStatus -> ShowS
[ThreadStatus] -> ShowS
ThreadStatus -> String
(Int -> ThreadStatus -> ShowS)
-> (ThreadStatus -> String)
-> ([ThreadStatus] -> ShowS)
-> Show ThreadStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThreadStatus -> ShowS
showsPrec :: Int -> ThreadStatus -> ShowS
$cshow :: ThreadStatus -> String
show :: ThreadStatus -> String
$cshowList :: [ThreadStatus] -> ShowS
showList :: [ThreadStatus] -> ShowS
Show 
           )


threadStatus :: ThreadId -> IO ThreadStatus
threadStatus :: ThreadId -> IO ThreadStatus
threadStatus (ThreadId ThreadId#
t) = (State# RealWorld -> (# State# RealWorld, ThreadStatus #))
-> IO ThreadStatus
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, ThreadStatus #))
 -> IO ThreadStatus)
-> (State# RealWorld -> (# State# RealWorld, ThreadStatus #))
-> IO ThreadStatus
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', Int -> ThreadStatus
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) = (State# RealWorld -> (# State# RealWorld, (Int, Bool) #))
-> IO (Int, Bool)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, (Int, Bool) #))
 -> IO (Int, Bool))
-> (State# RealWorld -> (# State# RealWorld, (Int, Bool) #))
-> IO (Int, Bool)
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#)) #)





threadLabel :: ThreadId -> IO (Maybe String)
threadLabel :: ThreadId -> IO (Maybe String)
threadLabel (ThreadId ThreadId#
t) = (State# RealWorld -> (# State# RealWorld, Maybe String #))
-> IO (Maybe String)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Maybe String #))
 -> IO (Maybe String))
-> (State# RealWorld -> (# State# RealWorld, Maybe String #))
-> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case ThreadId#
-> State# RealWorld -> (# State# RealWorld, Int#, ByteArray# #)
threadLabel# ThreadId#
t State# RealWorld
s of
      (# State# RealWorld
s', Int#
1#, ByteArray#
lbl #) ->
          let lbl' :: String
lbl' = ByteArray# -> String
utf8DecodeByteArray# ByteArray#
lbl
          in (# State# RealWorld
s', String -> Maybe String
forall a. a -> Maybe a
Just String
lbl' #)
      (# State# RealWorld
s', Int#
0#, ByteArray#
_ #) -> (# State# RealWorld
s', Maybe String
forall a. Maybe a
Nothing #)
      (# State# RealWorld, Int#, ByteArray# #)
_ -> String -> (# State# RealWorld, Maybe String #)
forall a. HasCallStack => String -> a
error String
"threadLabel: impossible"

















mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
mkWeakThreadId t :: ThreadId
t@(ThreadId ThreadId#
t#) = (State# RealWorld -> (# State# RealWorld, Weak ThreadId #))
-> IO (Weak ThreadId)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Weak ThreadId #))
 -> IO (Weak ThreadId))
-> (State# RealWorld -> (# State# RealWorld, Weak ThreadId #))
-> IO (Weak ThreadId)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
   case ThreadId#
-> ThreadId
-> State# RealWorld
-> (# State# RealWorld, Weak# ThreadId #)
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, Weak# ThreadId -> Weak ThreadId
forall v. Weak# v -> Weak v
Weak Weak# ThreadId
w #)










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 STM a -> (a -> STM b) -> STM b
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> STM b
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> STM b) -> (a -> b) -> a -> STM b
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 = a -> STM a
forall a. a -> STM a
returnSTM a
x
  <*> :: forall a b. STM (a -> b) -> STM a -> STM 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 = (a -> b -> c) -> STM a -> STM b -> STM c
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 = STM a -> STM b -> STM b
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     = STM a -> (a -> STM b) -> STM b
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
(>>) = STM a -> STM b -> STM b
forall a b. STM a -> STM b -> STM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)


instance Semigroup a => Semigroup (STM a) where
    <> :: STM a -> STM a -> STM a
(<>) = (a -> a -> a) -> STM a -> STM a -> STM a
forall a b c. (a -> b -> c) -> STM a -> STM b -> STM c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)


instance Monoid a => Monoid (STM a) where
    mempty :: STM a
mempty = a -> STM a
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

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 = (State# RealWorld -> (# State# RealWorld, b #)) -> STM b
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 #) -> STM b -> State# RealWorld -> (# State# RealWorld, b #)
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 = (State# RealWorld -> (# State# RealWorld, b #)) -> STM b
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
_ #) -> STM b -> State# RealWorld -> (# State# RealWorld, b #)
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 = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
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 = STM a
forall a. STM a
retry
  <|> :: forall a. STM a -> STM a -> STM 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) = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
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) = (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> ((State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld -> (# State# RealWorld, a #)
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 = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, a #)) -> STM a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# -> State# RealWorld -> (# State# RealWorld, a #)
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 = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, a #)) -> STM a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> (State# RealWorld -> (# State# RealWorld, a #))
-> (State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld
-> (# State# RealWorld, a #)
forall a.
(State# RealWorld -> (# State# RealWorld, a #))
-> (State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld
-> (# State# RealWorld, a #)
catchRetry# State# RealWorld -> (# State# RealWorld, a #)
m (STM a -> State# RealWorld -> (# State# RealWorld, a #)
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 = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, a #)) -> STM a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a b. (a -> b) -> a -> b
$ SomeException -> State# RealWorld -> (# State# RealWorld, a #)
forall a b. a -> State# RealWorld -> (# State# RealWorld, b #)
raiseIO# (e -> SomeException
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 = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, a #)) -> STM a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a b. (a -> b) -> a -> b
$ (State# RealWorld -> (# State# RealWorld, a #))
-> (SomeException -> State# RealWorld -> (# State# RealWorld, a #))
-> State# RealWorld
-> (# State# RealWorld, a #)
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 SomeException -> Maybe e
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                     Just e
e' -> STM a -> State# RealWorld -> (# State# RealWorld, a #)
forall a. STM a -> State# RealWorld -> (# State# RealWorld, a #)
unSTM (e -> STM a
handler e
e')
                     Maybe e
Nothing -> SomeException -> State# RealWorld -> (# State# RealWorld, a #)
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# (TVar# RealWorld a -> TVar# RealWorld a -> Int#
forall s a. TVar# s a -> TVar# s 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 = (State# RealWorld -> (# State# RealWorld, TVar a #))
-> STM (TVar a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, TVar a #))
 -> STM (TVar a))
-> (State# RealWorld -> (# State# RealWorld, TVar a #))
-> STM (TVar a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
    case a -> State# RealWorld -> (# State# RealWorld, TVar# RealWorld a #)
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#, TVar# RealWorld a -> TVar a
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 = (State# RealWorld -> (# State# RealWorld, TVar a #)) -> IO (TVar a)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, TVar a #))
 -> IO (TVar a))
-> (State# RealWorld -> (# State# RealWorld, TVar a #))
-> IO (TVar a)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
    case a -> State# RealWorld -> (# State# RealWorld, TVar# RealWorld a #)
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#, TVar# RealWorld a -> TVar a
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#) = (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, a #)) -> IO a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# -> TVar# RealWorld a -> State# RealWorld -> (# State# RealWorld, a #)
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#) = (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, a #)) -> STM a)
-> (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# -> TVar# RealWorld a -> State# RealWorld -> (# State# RealWorld, a #)
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 = (State# RealWorld -> (# State# RealWorld, () #)) -> STM ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> STM a
STM ((State# RealWorld -> (# State# RealWorld, () #)) -> STM ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> STM ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s1# ->
    case TVar# RealWorld a -> a -> State# RealWorld -> State# RealWorld
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 a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    a <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
m
    b <- catchAny (restore (io a))
            (\e
e -> do MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
m a
a; e -> IO b
forall a e. (HasCallStack, Exception e) => e -> a
throw e
e)
    putMVar m a
    return 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 a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    a <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
m
    a' <- catchAny (restore (io a))
            (\e
e -> do MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
m a
a; e -> IO a
forall a e. (HasCallStack, Exception e) => e -> a
throw e
e)
    putMVar m a'
    return ()












sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
 a
a Ptr a -> IO (Ptr a)
get_or_set =
   IO a -> IO a
forall a. IO a -> IO a
mask_ (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
     stable_ref <- a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
newStablePtr a
a
     let ref = Ptr () -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr (StablePtr a -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr StablePtr a
stable_ref)
     ref2 <- get_or_set ref
     if ref==ref2
        then return a
        else do freeStablePtr stable_ref
                deRefStablePtr (castPtrToStablePtr (castPtr ref2))

reportStackOverflow :: IO ()
reportStackOverflow :: IO ()
reportStackOverflow = do
     ThreadId tid <- IO ThreadId
myThreadId
     c_reportStackOverflow tid

reportError :: SomeException -> IO ()
reportError :: SomeException -> IO ()
reportError SomeException
ex = do
   handler <- IO (SomeException -> IO ())
getUncaughtExceptionHandler
   handler 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 = IO (IORef (SomeException -> IO ()))
-> IORef (SomeException -> IO ())
forall a. IO a -> a
unsafePerformIO ((SomeException -> IO ()) -> IO (IORef (SomeException -> IO ()))
forall a. a -> IO (IORef a)
newIORef SomeException -> IO ()
defaultHandler)
   where
      defaultHandler :: SomeException -> IO ()
      defaultHandler :: SomeException -> IO ()
defaultHandler SomeException
se = do
         (Handle -> IO ()
hFlush Handle
stdout) IO ()
-> (forall e. (HasExceptionContext, Exception e) => e -> IO ())
-> IO ()
forall a.
IO a
-> (forall e. (HasExceptionContext, Exception e) => e -> IO a)
-> IO a
`catchAny` (\ e
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

         let exMsg :: String
exMsg = SomeException -> String
displayExceptionWithInfo SomeException
se
             msg :: String
msg = String
"Uncaught exception " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
exMsg
         String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
"%s" ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cfmt ->
          String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
msg ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
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 = IORef (SomeException -> IO ()) -> (SomeException -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
uncaughtExceptionHandler

getUncaughtExceptionHandler :: IO (SomeException -> IO ())
getUncaughtExceptionHandler :: IO (SomeException -> IO ())
getUncaughtExceptionHandler = IORef (SomeException -> IO ()) -> IO (SomeException -> IO ())
forall a. IORef a -> IO a
readIORef IORef (SomeException -> IO ())
uncaughtExceptionHandler