(original) (raw)

{-# 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](GHC.Conc.Sync.html#forkIO)
    , [forkIOWithUnmask](GHC.Conc.Sync.html#forkIOWithUnmask)
    , [forkOn](GHC.Conc.Sync.html#forkOn)
    , [forkOnWithUnmask](GHC.Conc.Sync.html#forkOnWithUnmask)
    , [numCapabilities](GHC.Conc.Sync.html#numCapabilities)
    , [getNumCapabilities](GHC.Conc.Sync.html#getNumCapabilities)
    , [setNumCapabilities](GHC.Conc.Sync.html#setNumCapabilities)
    , [getNumProcessors](GHC.Conc.Sync.html#getNumProcessors)
    , [numSparks](GHC.Conc.Sync.html#numSparks)
    , [childHandler](GHC.Conc.Sync.html#childHandler)
    , [myThreadId](GHC.Conc.Sync.html#myThreadId)
    , [killThread](GHC.Conc.Sync.html#killThread)
    , [throwTo](GHC.Conc.Sync.html#throwTo)
    , [par](GHC.Conc.Sync.html#par)
    , [pseq](GHC.Conc.Sync.html#pseq)
    , [runSparks](GHC.Conc.Sync.html#runSparks)
    , [yield](GHC.Conc.Sync.html#yield)
    , [labelThread](GHC.Conc.Sync.html#labelThread)
    , [mkWeakThreadId](GHC.Conc.Sync.html#mkWeakThreadId)

    , [ThreadStatus](GHC.Conc.Sync.html#ThreadStatus)(..), [BlockReason](GHC.Conc.Sync.html#BlockReason)(..)
    , [threadStatus](GHC.Conc.Sync.html#threadStatus)
    , [threadCapability](GHC.Conc.Sync.html#threadCapability)

    , [newStablePtrPrimMVar](GHC.Conc.Sync.html#newStablePtrPrimMVar), [PrimMVar](GHC.Conc.Sync.html#PrimMVar)

    
    , [setAllocationCounter](GHC.Conc.Sync.html#setAllocationCounter)
    , [getAllocationCounter](GHC.Conc.Sync.html#getAllocationCounter)
    , [enableAllocationLimit](GHC.Conc.Sync.html#enableAllocationLimit)
    , [disableAllocationLimit](GHC.Conc.Sync.html#disableAllocationLimit)

    
    , [STM](GHC.Conc.Sync.html#STM)(..)
    , [atomically](GHC.Conc.Sync.html#atomically)
    , [retry](GHC.Conc.Sync.html#retry)
    , [orElse](GHC.Conc.Sync.html#orElse)
    , [throwSTM](GHC.Conc.Sync.html#throwSTM)
    , [catchSTM](GHC.Conc.Sync.html#catchSTM)
    , [TVar](GHC.Conc.Sync.html#TVar)(..)
    , [newTVar](GHC.Conc.Sync.html#newTVar)
    , [newTVarIO](GHC.Conc.Sync.html#newTVarIO)
    , [readTVar](GHC.Conc.Sync.html#readTVar)
    , [readTVarIO](GHC.Conc.Sync.html#readTVarIO)
    , [writeTVar](GHC.Conc.Sync.html#writeTVar)
    , [unsafeIOToSTM](GHC.Conc.Sync.html#unsafeIOToSTM)

    
    , [withMVar](GHC.Conc.Sync.html#withMVar)
    , [modifyMVar_](GHC.Conc.Sync.html#modifyMVar%5F)

    , [setUncaughtExceptionHandler](GHC.Conc.Sync.html#setUncaughtExceptionHandler)
    , [getUncaughtExceptionHandler](GHC.Conc.Sync.html#getUncaughtExceptionHandler)

    , [reportError](GHC.Conc.Sync.html#reportError), [reportStackOverflow](GHC.Conc.Sync.html#reportStackOverflow), [reportHeapOverflow](GHC.Conc.Sync.html#reportHeapOverflow)

    , [sharedCAF](GHC.Conc.Sync.html#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 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 -> CInt -> ShowS 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 = ThreadId -> String 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 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# Int# 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 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 = (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, 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 = (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 (IO () -> State# RealWorld -> (# State# RealWorld, ThreadId# #) 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 = 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 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# -> IO () -> State# RealWorld -> (# State# RealWorld, ThreadId# #) 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 = 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 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 CInt n <- Ptr CInt -> IO CInt forall a. Storable a => Ptr a -> IO a peek Ptr CInt enabled_capabilities Int -> IO Int forall (m :: * -> *) a. Monad m => a -> m a return (CInt -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral CInt 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 (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 (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 (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 (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 ThreadId# t) String str = TextEncoding -> String -> (CString -> IO ()) -> IO () forall a. TextEncoding -> String -> (CString -> IO a) -> IO a GHC.Foreign.withCString TextEncoding utf8 String str ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ (Ptr Addr# p) -> (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# -> 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 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#, Any #) 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 Any -> (# State# d, () #) -> (# State# d, () #) seq State# d -> (# State# d, () #) loop State# d s'

data BlockReason = BlockedOnMVar

| BlockedOnBlackHole

| BlockedOnException

| BlockedOnSTM

| BlockedOnForeignCall

| BlockedOnIOCompletion

| BlockedOnOther

deriving ( BlockReason -> BlockReason -> Bool (BlockReason -> BlockReason -> Bool) -> (BlockReason -> BlockReason -> Bool) -> Eq BlockReason 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 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 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 (Int -> BlockReason -> ShowS) -> (BlockReason -> String) -> ([BlockReason] -> ShowS) -> Show BlockReason 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 (ThreadStatus -> ThreadStatus -> Bool) -> (ThreadStatus -> ThreadStatus -> Bool) -> Eq ThreadStatus 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 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 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 (Int -> ThreadStatus -> ShowS) -> (ThreadStatus -> String) -> ([ThreadStatus] -> ShowS) -> Show ThreadStatus 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) = (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 15 = BlockReason -> ThreadStatus ThreadBlocked BlockReason BlockedOnIOCompletion

 [mk_stat](#local-6989586621679590141) 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#)) #)

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 #) 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 #)

data PrimMVar

newStablePtrPrimMVar :: MVar () -> IO (StablePtr PrimMVar) newStablePtrPrimMVar :: MVar () -> IO (StablePtr PrimMVar) newStablePtrPrimMVar (MVar MVar# RealWorld () m) = (State# RealWorld -> (# State# RealWorld, StablePtr PrimMVar #)) -> IO (StablePtr PrimMVar) forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a IO ((State# RealWorld -> (# State# RealWorld, StablePtr PrimMVar #)) -> IO (StablePtr PrimMVar)) -> (State# RealWorld -> (# State# RealWorld, StablePtr PrimMVar #)) -> IO (StablePtr PrimMVar) forall a b. (a -> b) -> a -> b $ \State# RealWorld s0 -> case PrimMVar -> State# RealWorld -> (# State# RealWorld, StablePtr# PrimMVar #) forall a. a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) makeStablePtr# (MVar# RealWorld () -> PrimMVar forall a b. a -> b unsafeCoerce# MVar# RealWorld () m :: PrimMVar) State# RealWorld s0 of

(# State# RealWorld

s1, StablePtr# PrimMVar sp #) -> (# State# RealWorld s1, StablePtr# PrimMVar -> StablePtr PrimMVar 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 STM a -> (a -> STM b) -> STM b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (b -> STM b 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 (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 = (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 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 = (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 a <- MVar a -> IO a forall a. MVar a -> IO a takeMVar MVar a m b b <- IO b -> (forall e. Exception e => e -> IO b) -> IO b forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a catchAny (IO b -> IO b forall a. IO a -> IO a restore (a -> IO b io a 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. Exception e => e -> a throw e e) MVar a -> a -> IO () forall a. MVar a -> a -> IO () putMVar MVar a m a a b -> IO b 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 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 a <- MVar a -> IO a forall a. MVar a -> IO a takeMVar MVar a m a a' <- IO a -> (forall e. Exception e => e -> IO a) -> IO a forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a catchAny (IO a -> IO a forall a. IO a -> IO a restore (a -> IO a io a 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. Exception e => e -> a throw e e) MVar a -> a -> IO () forall a. MVar a -> a -> IO () putMVar MVar a m a a' () -> IO () 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 = 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 StablePtr a stable_ref <- a -> IO (StablePtr a) forall a. a -> IO (StablePtr a) newStablePtr a a let ref :: Ptr b 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) Ptr a ref2 <- Ptr a -> IO (Ptr a) get_or_set Ptr a forall {b}. Ptr b ref if Ptr a forall {b}. Ptr b refPtr a -> Ptr a -> Bool forall a. Eq a => a -> a -> Bool ==Ptr a ref2 then a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return a a else do StablePtr a -> IO () forall a. StablePtr a -> IO () freeStablePtr StablePtr a stable_ref StablePtr a -> IO a forall a. StablePtr a -> IO a deRefStablePtr (Ptr () -> StablePtr a forall a. Ptr () -> StablePtr a castPtrToStablePtr (Ptr a -> Ptr () 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 = 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 se :: SomeException se@(SomeException e ex) = do (Handle -> IO () hFlush Handle stdout) IO () -> (forall e. Exception e => e -> IO ()) -> IO () forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a catchAny (\ e _ -> () -> IO () forall (m :: * -> *) a. Monad m => a -> m a return ()) let msg :: String msg = case e -> Maybe Deadlock 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 _ -> Int -> SomeException -> ShowS forall a. Show a => Int -> a -> ShowS showsPrec Int 0 SomeException se String "" 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