X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=026aff5a11a88d4a4a4710e829408d2d2095c7b8;hb=c131671f4b4b2583e7e4a6145360270fe6146e57;hp=9707ad049916b2f007067880061176bf72caa176;hpb=b29b736b406be134e783b8322cb09a6433acf108;p=ghc-base.git diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index 9707ad0..1b5ff7e 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -1,5 +1,8 @@ \begin{code} -{-# OPTIONS -fno-implicit-prelude #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_HADDOCK not-home #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Conc @@ -14,329 +17,95 @@ -- ----------------------------------------------------------------------------- -#include "config.h" -module GHC.Conc - ( ThreadId(..) - - -- Forking and suchlike - , myThreadId -- :: IO ThreadId - , killThread -- :: ThreadId -> IO () - , throwTo -- :: ThreadId -> Exception -> IO () - , par -- :: a -> b -> b - , pseq -- :: a -> b -> b - , yield -- :: IO () - , labelThread -- :: ThreadId -> String -> IO () - , forkProcessPrim -- :: IO Int - - -- Waiting - , threadDelay -- :: Int -> IO () - , threadWaitRead -- :: Int -> IO () - , threadWaitWrite -- :: Int -> IO () - - -- MVars - , MVar -- abstract - , newMVar -- :: a -> IO (MVar a) - , newEmptyMVar -- :: IO (MVar a) - , takeMVar -- :: MVar a -> IO a - , putMVar -- :: MVar a -> a -> IO () - , tryTakeMVar -- :: MVar a -> IO (Maybe a) - , tryPutMVar -- :: MVar a -> a -> IO Bool - , isEmptyMVar -- :: MVar a -> IO Bool - , addMVarFinalizer -- :: MVar a -> IO () -> IO () +-- No: #hide, because bits of this module are exposed by the stm package. +-- However, we don't want this module to be the home location for the +-- bits it exports, we'd rather have Control.Concurrent and the other +-- higher level modules be the home. Hence: -#ifdef mingw32_TARGET_OS - , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) - , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) +#include "Typeable.h" - , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) - , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) +-- #not-home +module GHC.Conc + ( ThreadId(..) + + -- * Forking and suchlike + , forkIO -- :: IO a -> IO ThreadId + , forkIOUnmasked + , forkOnIO -- :: Int -> IO a -> IO ThreadId + , forkOnIOUnmasked + , numCapabilities -- :: Int + , getNumCapabilities -- :: IO Int + , numSparks -- :: IO Int + , childHandler -- :: Exception -> IO () + , myThreadId -- :: IO ThreadId + , killThread -- :: ThreadId -> IO () + , throwTo -- :: ThreadId -> Exception -> IO () + , par -- :: a -> b -> b + , pseq -- :: a -> b -> b + , runSparks + , yield -- :: IO () + , labelThread -- :: ThreadId -> String -> IO () + + , ThreadStatus(..), BlockReason(..) + , threadStatus -- :: ThreadId -> IO ThreadStatus + + -- * Waiting + , threadDelay -- :: Int -> IO () + , registerDelay -- :: Int -> IO (TVar Bool) + , threadWaitRead -- :: Int -> IO () + , threadWaitWrite -- :: Int -> IO () + , closeFdWith -- :: (Fd -> IO ()) -> Fd -> IO () + + -- * TVars + , STM(..) + , atomically -- :: STM a -> IO a + , retry -- :: STM a + , orElse -- :: STM a -> STM a -> STM a + , throwSTM -- :: Exception e => e -> STM a + , catchSTM -- :: Exception e => STM a -> (e -> STM a) -> STM a + , alwaysSucceeds -- :: STM a -> STM () + , always -- :: STM Bool -> STM () + , TVar(..) + , newTVar -- :: a -> STM (TVar a) + , newTVarIO -- :: a -> STM (TVar a) + , readTVar -- :: TVar a -> STM a + , readTVarIO -- :: TVar a -> IO a + , writeTVar -- :: a -> TVar a -> STM () + , unsafeIOToSTM -- :: IO a -> STM a + + -- * Miscellaneous + , withMVar +#ifdef mingw32_HOST_OS + , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) + , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) + , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int + + , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) + , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) #endif - ) where - -import Data.Maybe - -import GHC.Base -import GHC.IOBase ( IO(..), MVar(..), ioException, IOException(..), IOErrorType(..) ) -import GHC.Num ( fromInteger, negate ) -import GHC.Real ( fromIntegral ) -import GHC.Base ( Int(..) ) -import GHC.Exception ( Exception(..), AsyncException(..) ) -import GHC.Pack ( packCString# ) -import GHC.Ptr ( Ptr(..), plusPtr ) - -infixr 0 `par`, `pseq` -\end{code} - -%************************************************************************ -%* * -\subsection{@ThreadId@, @par@, and @fork@} -%* * -%************************************************************************ - -\begin{code} -data ThreadId = ThreadId ThreadId# --- ToDo: data ThreadId = ThreadId (Weak ThreadId#) --- But since ThreadId# is unlifted, the Weak type must use open --- type variables. -{- ^ -A 'ThreadId' is an abstract type representing a handle to a thread. -'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where -the 'Ord' instance implements an arbitrary total ordering over -'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued -'ThreadId' to string form; showing a 'ThreadId' value is occasionally -useful when debugging or diagnosing the behaviour of a concurrent -program. - -NOTE: in GHC, if you have a 'ThreadId', you essentially have -a pointer to the thread itself. This means the thread itself can\'t be -garbage collected until you drop the 'ThreadId'. -This misfeature will hopefully be corrected at a later date. --} - ---forkIO has now been hoisted out into the Concurrent library. - -{- | 'killThread' terminates the given thread (Note: 'killThread' is -not implemented in Hugs). Any work already done by the thread isn\'t -lost: the computation is suspended until required by another thread. -The memory used by the thread will be garbage collected if it isn\'t -referenced from anywhere. The 'killThread' function is defined in -terms of 'throwTo': - -> killThread tid = throwTo tid (AsyncException ThreadKilled) - --} -killThread :: ThreadId -> IO () -killThread tid = throwTo tid (AsyncException ThreadKilled) - -{- | 'throwTo' raises an arbitrary exception in the target thread. - -'throwTo' does not return until the exception has been raised in the -target thread. The calling thread can thus be certain that the target -thread has received the exception. This is a useful property to know -when dealing with race conditions: eg. if there are two threads that -can kill each other, it is guaranteed that only one of the threads -will get to kill the other. -} -throwTo :: ThreadId -> Exception -> IO () -throwTo (ThreadId id) ex = IO $ \ s -> - case (killThread# id ex s) of s1 -> (# s1, () #) - --- | Returns the 'ThreadId' of the calling thread. -myThreadId :: IO ThreadId -myThreadId = IO $ \s -> - case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #) - - --- |The 'yield' action allows (forces, in a co-operative multitasking --- implementation) a context-switch to any other currently runnable --- threads (if any), and is occasionally useful when implementing --- concurrency abstractions. -yield :: IO () -yield = IO $ \s -> - case (yield# s) of s1 -> (# s1, () #) - -{- | 'labelThread' stores a string as identifier for this thread if -you built a RTS with debugging support. This identifier will be used in -the debugging output to make distinction of different threads easier -(otherwise you only have the thread state object\'s address in the heap). - -Other applications like the graphical Concurrent Haskell Debugger -() may choose to overload -'labelThread' for their purposes as well. --} - -labelThread :: ThreadId -> String -> IO () -labelThread (ThreadId t) str = IO $ \ s -> - let ps = packCString# str - adr = byteArrayContents# ps in - case (labelThread# t adr s) of s1 -> (# s1, () #) - -{- | This function is a replacement for "System.Posix.Process.forkProcessAll": -This implementation /will stop all other Concurrent Haskell threads/ in the -(heavyweight) forked copy. -'forkProcessPrim' returns the pid of the child process to the parent, 0 to the -child, and a value less than 0 in case of errors. See also: -'System.Posix.Process.forkProcess' in package @unix@. - -Without this function, you need excessive and often impractical -explicit synchronization using the regular Concurrent Haskell constructs to assure -that only the desired thread is running after the fork(). - -The stopped threads are /not/ garbage collected! This behaviour may change in -future releases. - -NOTE: currently, main threads are not stopped in the child process. -To work around this problem, call 'forkProcessPrim' from the main thread. --} - --- XXX RTS should know about 'pid_t'. - -forkProcessPrim :: IO Int -forkProcessPrim = IO $ \s -> case (forkProcess# s) of (# s1, id #) -> (# s1, (I# id) #) - --- Nota Bene: 'pseq' used to be 'seq' --- but 'seq' is now defined in PrelGHC --- --- "pseq" is defined a bit weirdly (see below) --- --- The reason for the strange "lazy" call is that --- it fools the compiler into thinking that pseq and par are non-strict in --- their second argument (even if it inlines pseq at the call site). --- If it thinks pseq is strict in "y", then it often evaluates --- "y" before "x", which is totally wrong. - -{-# 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 } -\end{code} - -%************************************************************************ -%* * -\subsection[mvars]{M-Structures} -%* * -%************************************************************************ - -M-Vars are rendezvous points for concurrent threads. They begin -empty, and any attempt to read an empty M-Var blocks. When an M-Var -is written, a single blocked thread may be freed. Reading an M-Var -toggles its state from full back to empty. Therefore, any value -written to an M-Var may only be read once. Multiple reads and writes -are allowed, but there must be at least one read between any two -writes. - -\begin{code} ---Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a) - --- |Create an 'MVar' which is initially empty. -newEmptyMVar :: IO (MVar a) -newEmptyMVar = IO $ \ s# -> - case newMVar# s# of - (# s2#, svar# #) -> (# s2#, MVar svar# #) - --- |Create an 'MVar' which contains the supplied value. -newMVar :: a -> IO (MVar a) -newMVar value = - newEmptyMVar >>= \ mvar -> - putMVar mvar value >> - return mvar - --- |Return the contents of the 'MVar'. If the 'MVar' is currently --- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', --- the 'MVar' is left empty. --- --- If several threads are competing to take the same 'MVar', one is chosen --- to continue at random when the 'MVar' becomes full. -takeMVar :: MVar a -> IO a -takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s# - --- |Put a value into an 'MVar'. If the 'MVar' is currently full, --- 'putMVar' will wait until it becomes empty. --- --- If several threads are competing to fill the same 'MVar', one is --- chosen to continue at random with the 'MVar' becomes empty. -putMVar :: MVar a -> a -> IO () -putMVar (MVar mvar#) x = IO $ \ s# -> - case putMVar# mvar# x s# of - s2# -> (# s2#, () #) - --- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function --- returns immediately, with 'Nothing' if the 'MVar' was empty, or --- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar', --- the 'MVar' is left empty. -tryTakeMVar :: MVar a -> IO (Maybe a) -tryTakeMVar (MVar m) = IO $ \ s -> - case tryTakeMVar# m s of - (# s, 0#, _ #) -> (# s, Nothing #) -- MVar is empty - (# s, _, a #) -> (# s, Just a #) -- MVar is full - --- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function --- attempts to put the value @a@ into the 'MVar', returning 'True' if --- it was successful, or 'False' otherwise. -tryPutMVar :: MVar a -> a -> IO Bool -tryPutMVar (MVar mvar#) x = IO $ \ s# -> - case tryPutMVar# mvar# x s# of - (# s, 0# #) -> (# s, False #) - (# s, _ #) -> (# s, True #) --- |Check whether a given 'MVar' is empty. --- --- Notice that the boolean value returned is just a snapshot of --- the state of the MVar. By the time you get to react on its result, --- the MVar may have been filled (or emptied) - so be extremely --- careful when using this operation. Use 'tryTakeMVar' instead if possible. -isEmptyMVar :: MVar a -> IO Bool -isEmptyMVar (MVar mv#) = IO $ \ s# -> - case isEmptyMVar# mv# s# of - (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #) - --- |Add a finalizer to an 'MVar'. See "Foreign.ForeignPtr" and --- "System.Mem.Weak" for more about finalizers. -addMVarFinalizer :: MVar a -> IO () -> IO () -addMVarFinalizer (MVar m) finalizer = - IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) } -\end{code} - - -%************************************************************************ -%* * -\subsection{Thread waiting} -%* * -%************************************************************************ - -@threadWaitRead@ delays rescheduling of a thread until input on the -specified file descriptor is available for reading (just like select). -@threadWaitWrite@ is similar, but for writing on a file descriptor. - -\begin{code} --- |The 'threadDelay' operation will cause the current thread to --- suspend for a given number of microseconds. Note that the resolution --- used by the Haskell runtime system\'s internal timer together with the --- fact that the thread may take some time to be rescheduled after the --- time has expired, means that the accuracy is more like 1\/50 second. -threadDelay :: Int -> IO () - --- | Block the current thread until data is available to read on the --- given file descriptor. -threadWaitRead :: Int -> IO () - --- | Block the current thread until data can be written to the --- given file descriptor. -threadWaitWrite :: Int -> IO () - -threadDelay (I# ms) = IO $ \s -> case delay# ms s of s -> (# s, () #) -threadWaitRead (I# fd) = IO $ \s -> case waitRead# fd s of s -> (# s, () #) -threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #) - -#ifdef mingw32_TARGET_OS - --- Note: threadDelay, threadWaitRead and threadWaitWrite aren't really functional --- on Win32, but left in there because lib code (still) uses them (the manner --- in which they're used doesn't cause problems on a Win32 platform though.) +#ifndef mingw32_HOST_OS + , Signal, HandlerFun, setHandler, runHandlers +#endif -asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) -asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) = - IO $ \s -> case asyncRead# fd isSock len buf s of - (# s, len#, err# #) -> (# s, (I# len#, I# err#) #) + , ensureIOManagerIsRunning -asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) -asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) = - IO $ \s -> case asyncWrite# fd isSock len buf s of - (# s, len#, err# #) -> (# s, (I# len#, I# err#) #) +#ifdef mingw32_HOST_OS + , ConsoleEvent(..) + , win32ConsoleHandler + , toWin32ConsoleEvent +#endif + , setUncaughtExceptionHandler -- :: (Exception -> IO ()) -> IO () + , getUncaughtExceptionHandler -- :: IO (Exception -> IO ()) --- to aid the use of these primops by the IO Handle implementation, --- provide the following convenience funs: + , reportError, reportStackOverflow + ) where --- this better be a pinned byte array! -asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int) -asyncReadBA fd isSock len off bufB = - asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off) - -asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int) -asyncWriteBA fd isSock len off bufB = - asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off) +import GHC.Conc.IO +import GHC.Conc.Sync +#ifndef mingw32_HOST_OS +import GHC.Conc.Signal #endif + \end{code}