-% -----------------------------------------------------------------------------
-% $Id: Conc.lhs,v 1.2 2001/07/03 14:13:32 simonmar Exp $
-%
-% (c) The University of Glasgow, 1994-2000
-%
-
-\section[GHC.Conc]{Module @GHC.Conc@}
-
-Basic concurrency stuff
-
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Conc
+-- Copyright : (c) The University of Glasgow, 1994-2002
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC extensions)
+--
+-- Basic concurrency stuff.
+--
+-----------------------------------------------------------------------------
+#include "config.h"
module GHC.Conc
( ThreadId(..)
, killThread -- :: ThreadId -> IO ()
, throwTo -- :: ThreadId -> Exception -> IO ()
, par -- :: a -> b -> b
- , seq -- :: a -> b -> b
+ , pseq -- :: a -> b -> b
, yield -- :: IO ()
+ , labelThread -- :: ThreadId -> String -> IO ()
+ , forkProcessPrim -- :: IO Int
-- Waiting
, threadDelay -- :: Int -> IO ()
, isEmptyMVar -- :: MVar a -> IO Bool
, addMVarFinalizer -- :: MVar a -> IO () -> IO ()
- ) where
+#ifdef mingw32_TARGET_OS
+ , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
+ , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, 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.Err ( parError, seqError )
-import GHC.IOBase ( IO(..), MVar(..) )
+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`, `seq`
+infixr 0 `par`, `pseq`
\end{code}
%************************************************************************
-- 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 (ThreadId id) = IO $ \ s ->
- case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #)
+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, () #)
--- "seq" is defined a bit weirdly (see below)
+{- | '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
+(<http://www.informatik.uni-kiel.de/~fhu/chd/>) 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
--
--- The reason for the strange "0# -> parError" case is that
--- it fools the compiler into thinking that seq is non-strict in
--- its second argument (even if it inlines seq at the call site).
--- If it thinks seq is strict in "y", then it often evaluates
--- "y" before "x", which is totally wrong.
+-- "pseq" is defined a bit weirdly (see below)
--
--- Just before converting from Core to STG there's a bit of magic
--- that recognises the seq# and eliminates the duff case.
+-- 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 seq #-}
-seq :: a -> b -> b
-seq x y = case (seq# x) of { 0# -> seqError; _ -> y }
+{-# 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 { 0# -> parError; _ -> y }
+par x y = case (par# x) of { _ -> lazy y }
\end{code}
%************************************************************************
\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#, () #)
-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 #)
-
-newMVar :: a -> IO (MVar a)
-newMVar value =
- newEmptyMVar >>= \ mvar ->
- putMVar mvar value >>
- return mvar
-
--- tryTakeMVar is a non-blocking takeMVar
+-- |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
-{-
- Low-level op. for checking whether an MVar is filled-in or not.
- 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.
+-- |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 #)
- If you can re-work your abstractions to avoid having to
- depend on isEmptyMVar, then you're encouraged to do so,
- i.e., consider yourself warned about the imprecision in
- general of isEmptyMVar :-)
--}
+-- |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#) #)
--- Like addForeignPtrFinalizer, but for MVars
+-- |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, () #) }
%* *
%************************************************************************
-@threadDelay@ delays rescheduling of a thread until the indicated
-number of microseconds have elapsed. Generally, the microseconds are
-counted by the context switch timer, which ticks in virtual time;
-however, when there are no runnable threads, we don't accumulate any
-virtual time, so we start ticking in real time. (The granularity is
-the effective resolution of the context switch timer, so it is
-affected by the RTS -C option.)
-
@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}
-threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
+-- |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.)
+
+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#) #)
+
+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#) #)
+
+-- to aid the use of these primops by the IO Handle implementation,
+-- provide the following convenience funs:
+
+-- 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)
+
+#endif
\end{code}
projects / ghc-base.git / blobdiff