(original) (raw)

{-# LANGUAGE Unsafe #-} {-# LANGUAGE CPP , NoImplicitPrelude , BangPatterns , MagicHash , UnboxedTuples , UnliftedFFITypes , StandaloneDeriving , RankNTypes #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-}

module GHC.Conc.Sync ( ThreadId(..)

    , [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.Handle.FD ( 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(..), showString ) import GHC.Stable ( StablePtr(..) ) import GHC.Weak

infixr 0 [par](GHC.Conc.Sync.html#par), [pseq](GHC.Conc.Sync.html#pseq)

data ThreadId = ThreadId ThreadId#

instance Show ThreadId where showsPrec d t = showString "ThreadId " . showsPrec d (getThreadId (id2TSO t))

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

id2TSO :: ThreadId -> ThreadId# id2TSO (ThreadId t) = t

foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt

cmpThread :: ThreadId -> ThreadId -> Ordering cmpThread t1 t2 = case cmp_thread (id2TSO t1) (id2TSO t2) of -1 -> LT 0 -> EQ _ -> GT

instance Eq ThreadId where t1 == t2 = case t1 [cmpThread](GHC.Conc.Sync.html#cmpThread) t2 of EQ -> True _ -> False

instance Ord ThreadId where compare = cmpThread

setAllocationCounter :: Int64 -> IO () setAllocationCounter (I64# i) = IO $ [s](#local-6989586621679347409) -> case setThreadAllocationCounter# i s of s' -> (# s', () #)

getAllocationCounter :: IO Int64 getAllocationCounter = IO $ [s](#local-6989586621679347411) -> case getThreadAllocationCounter# s of (# s', ctr #) -> (# s', I64# ctr #)

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

disableAllocationLimit :: IO () disableAllocationLimit = do ThreadId t <- 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 action = IO $ \ s -> case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #) where

action_plus = catch action childHandler

forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId forkIOWithUnmask io = forkIO (io unsafeUnmask)

forkOn :: Int -> IO () -> IO ThreadId forkOn (I# cpu) action = IO $ \ s -> case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #) where

action_plus = catch action childHandler

forkOnWithUnmask :: Int -> ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId forkOnWithUnmask cpu io = forkOn cpu (io unsafeUnmask)

numCapabilities :: Int numCapabilities = unsafePerformIO $ getNumCapabilities

getNumCapabilities :: IO Int getNumCapabilities = do n <- peek enabled_capabilities return (fromIntegral n)

setNumCapabilities :: Int -> IO () setNumCapabilities i | i <= 0 = fail $ "setNumCapabilities: Capability count ("++show i++") must be positive" | otherwise = c_setNumCapabilities (fromIntegral i)

foreign import ccall safe "setNumCapabilities" c_setNumCapabilities :: CUInt -> IO ()

getNumProcessors :: IO Int getNumProcessors = fmap fromIntegral c_getNumberOfProcessors

foreign import ccall unsafe "getNumberOfProcessors" c_getNumberOfProcessors :: IO CUInt

numSparks :: IO Int numSparks = IO $ [s](#local-6989586621679347432) -> case numSparks# s of (# s', n #) -> (# s', I# n #)

foreign import ccall "&enabled_capabilities" enabled_capabilities :: Ptr CInt

childHandler :: SomeException -> IO () childHandler err = catch (real_handler err) childHandler

real_handler :: SomeException -> IO () real_handler se | Just BlockedIndefinitelyOnMVar <- fromException se = return () | Just BlockedIndefinitelyOnSTM <- fromException se = return () | Just ThreadKilled <- fromException se = return () | Just StackOverflow <- fromException se = reportStackOverflow | otherwise = reportError se

killThread :: ThreadId -> IO () killThread tid = throwTo tid ThreadKilled

throwTo :: Exception e => ThreadId -> e -> IO () throwTo (ThreadId tid) ex = IO $ \ s -> case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)

myThreadId :: IO ThreadId myThreadId = IO $ [s](#local-6989586621679347442) -> case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)

yield :: IO () yield = IO $ [s](#local-6989586621679347445) -> case (yield# s) of s1 -> (# s1, () #)

labelThread :: ThreadId -> String -> IO () labelThread (ThreadId t) str = GHC.Foreign.withCString utf8 str $ (Ptr p) -> IO $ \ s -> case labelThread# t p s of s1 -> (# s1, () #)

{-# INLINE pseq #-} pseq :: a -> b -> b pseq x y = x seq lazy y

{-# INLINE par #-} par :: a -> b -> b par x y = case (par# x) of { _ -> lazy y }

runSparks :: IO () runSparks = IO loop where loop s = case getSpark# s of (# s', n, p #) -> if isTrue# (n ==# 0#) then (# s', () #) else p seq loop s'

data BlockReason = BlockedOnMVar

| BlockedOnBlackHole

| BlockedOnException

| BlockedOnSTM

| BlockedOnForeignCall

| BlockedOnOther

deriving ( Eq
, Ord
, Show )

data ThreadStatus = ThreadRunning

| ThreadFinished

| ThreadBlocked BlockReason

| ThreadDied

deriving ( Eq
, Ord
, Show )

threadStatus :: ThreadId -> IO ThreadStatus threadStatus (ThreadId t) = IO $ [s](#local-6989586621679347463) -> case threadStatus# t s of (# s', stat, _cap, _locked #) -> (# s', mk_stat (I# stat) #) where

 [mk_stat](#local-6989586621679347462) 0  = [ThreadRunning](GHC.Conc.Sync.html#ThreadRunning)
 mk_stat 1  = [ThreadBlocked](GHC.Conc.Sync.html#ThreadBlocked) [BlockedOnMVar](GHC.Conc.Sync.html#BlockedOnMVar)
 mk_stat 2  = [ThreadBlocked](GHC.Conc.Sync.html#ThreadBlocked) [BlockedOnBlackHole](GHC.Conc.Sync.html#BlockedOnBlackHole)
 mk_stat 6  = [ThreadBlocked](GHC.Conc.Sync.html#ThreadBlocked) [BlockedOnSTM](GHC.Conc.Sync.html#BlockedOnSTM)
 mk_stat 10 = [ThreadBlocked](GHC.Conc.Sync.html#ThreadBlocked) [BlockedOnForeignCall](GHC.Conc.Sync.html#BlockedOnForeignCall)
 mk_stat 11 = [ThreadBlocked](GHC.Conc.Sync.html#ThreadBlocked) [BlockedOnForeignCall](GHC.Conc.Sync.html#BlockedOnForeignCall)
 mk_stat 12 = [ThreadBlocked](GHC.Conc.Sync.html#ThreadBlocked) [BlockedOnException](GHC.Conc.Sync.html#BlockedOnException)
 mk_stat 14 = [ThreadBlocked](GHC.Conc.Sync.html#ThreadBlocked) [BlockedOnMVar](GHC.Conc.Sync.html#BlockedOnMVar) 
 
 mk_stat 16 = [ThreadFinished](GHC.Conc.Sync.html#ThreadFinished)
 mk_stat 17 = [ThreadDied](GHC.Conc.Sync.html#ThreadDied)
 mk_stat _  = [ThreadBlocked](GHC.Conc.Sync.html#ThreadBlocked) [BlockedOnOther](GHC.Conc.Sync.html#BlockedOnOther)

threadCapability :: ThreadId -> IO (Int, Bool) threadCapability (ThreadId t) = IO $ [s](#local-6989586621679347469) -> case threadStatus# t s of (# s', _, cap#, locked# #) -> (# s', (I# cap#, isTrue# (locked# /=# 0#)) #)

mkWeakThreadId :: ThreadId -> IO (Weak ThreadId) mkWeakThreadId t@(ThreadId t#) = IO $ [s](#local-6989586621679347475) -> case mkWeakNoFinalizer# t# t s of (# s1, w #) -> (# s1, Weak w #)

data PrimMVar

newStablePtrPrimMVar :: MVar () -> IO (StablePtr PrimMVar) newStablePtrPrimMVar (MVar m) = IO $ [s0](#local-6989586621679347479) -> case makeStablePtr# (unsafeCoerce# m :: PrimMVar) s0 of (# s1, sp #) -> (# s1, StablePtr sp #)

newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))

unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #)) unSTM (STM a) = a

instance Functor STM where fmap f x = x >>= (pure . f)

instance Applicative STM where {-# INLINE pure #-} {-# INLINE (*>) #-} {-# INLINE liftA2 #-} pure x = returnSTM x (<*>) = ap liftA2 = liftM2 m *> k = thenSTM m k

instance Monad STM where {-# INLINE (>>=) #-} m >>= k = bindSTM m k (>>) = (*>)

bindSTM :: STM a -> (a -> STM b) -> STM b bindSTM (STM m) k = STM ( [s](#local-6989586621679347485) -> case m s of (# new_s, a #) -> unSTM (k a) new_s )

thenSTM :: STM a -> STM b -> STM b thenSTM (STM m) k = STM ( [s](#local-6989586621679347490) -> case m s of (# new_s, _ #) -> unSTM k new_s )

returnSTM :: a -> STM a returnSTM x = STM ([s](#local-6989586621679347493) -> (# s, x #))

instance Alternative STM where empty = retry (<|>) = orElse

instance MonadPlus STM

unsafeIOToSTM :: IO a -> STM a unsafeIOToSTM (IO m) = STM m

atomically :: STM a -> IO a atomically (STM m) = IO ([s](#local-6989586621679347496) -> (atomically# m) s )

retry :: STM a retry = STM $ [s#](#local-6989586621679347497) -> retry# s#

orElse :: STM a -> STM a -> STM a orElse (STM m) e = STM $ [s](#local-6989586621679347500) -> catchRetry# m (unSTM e) s

throwSTM :: Exception e => e -> STM a throwSTM e = STM $ raiseIO# (toException e)

catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a catchSTM (STM m) handler = STM $ catchSTM# m handler' where handler' e = case fromException e of Just e' -> unSTM (handler e') Nothing -> raiseIO# e

data TVar a = TVar (TVar# RealWorld a)

instance Eq (TVar a) where (TVar tvar1#) == (TVar tvar2#) = isTrue# (sameTVar# tvar1# tvar2#)

newTVar :: a -> STM (TVar a) newTVar val = STM $ [s1#](#local-6989586621679347508) -> case newTVar# val s1# of (# s2#, tvar# #) -> (# s2#, TVar tvar# #)

newTVarIO :: a -> IO (TVar a) newTVarIO val = IO $ [s1#](#local-6989586621679347512) -> case newTVar# val s1# of (# s2#, tvar# #) -> (# s2#, TVar tvar# #)

readTVarIO :: TVar a -> IO a readTVarIO (TVar tvar#) = IO $ [s#](#local-6989586621679347516) -> readTVarIO# tvar# s#

readTVar :: TVar a -> STM a readTVar (TVar tvar#) = STM $ [s#](#local-6989586621679347518) -> readTVar# tvar# s#

writeTVar :: TVar a -> a -> STM () writeTVar (TVar tvar#) val = STM $ [s1#](#local-6989586621679347521) -> case writeTVar# tvar# val s1# of s2# -> (# s2#, () #)

withMVar :: MVar a -> (a -> IO b) -> IO b withMVar m io = mask $ [restore](#local-6989586621679347525) -> do a <- takeMVar m b <- catchAny (restore (io a)) ([e](#local-6989586621679347527) -> do putMVar m a; throw e) putMVar m a return b

modifyMVar_ :: MVar a -> (a -> IO a) -> IO () modifyMVar_ m io = mask $ [restore](#local-6989586621679347531) -> do a <- takeMVar m a' <- catchAny (restore (io a)) ([e](#local-6989586621679347533) -> do putMVar m a; throw e) putMVar m a' return ()

sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a sharedCAF a get_or_set = mask_ $ do stable_ref <- newStablePtr a let ref = castPtr (castStablePtrToPtr 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 = do ThreadId tid <- myThreadId c_reportStackOverflow tid

reportError :: SomeException -> IO () reportError ex = do handler <- 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 = unsafePerformIO (newIORef defaultHandler) where defaultHandler :: SomeException -> IO () defaultHandler se@(SomeException ex) = do (hFlush stdout) [catchAny](GHC.IO.html#catchAny) (\ _ -> return ()) let msg = case cast ex of Just Deadlock -> "no threads to run: infinite loop or deadlock?" _ -> showsPrec 0 se "" withCString "%s" $ [cfmt](#local-6989586621679347547) -> withCString msg $ [cmsg](#local-6989586621679347548) -> errorBelch cfmt cmsg

foreign import ccall unsafe "HsBase.h errorBelch2" errorBelch :: CString -> CString -> IO ()

setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO () setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler

getUncaughtExceptionHandler :: IO (SomeException -> IO ()) getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler