GHC/Conc.lhs

   1 \begin{code}
   2 {-# OPTIONS -fno-implicit-prelude #-}
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  GHC.Conc
   6 -- Copyright   :  (c) The University of Glasgow, 1994-2002
   7 -- License     :  see libraries/base/LICENSE
   8 --
   9 -- Maintainer  :  cvs-ghc@haskell.org
  10 -- Stability   :  internal
  11 -- Portability :  non-portable (GHC extensions)
  12 --
  13 -- Basic concurrency stuff.
  14 --
  15 -----------------------------------------------------------------------------
  16
  17 module GHC.Conc
  18         ( ThreadId(..)
  19
  20         -- Forking and suchlike
  21         , myThreadId    -- :: IO ThreadId
  22         , killThread    -- :: ThreadId -> IO ()
  23         , throwTo       -- :: ThreadId -> Exception -> IO ()
  24         , par           -- :: a -> b -> b
  25         , pseq          -- :: a -> b -> b
  26         , yield         -- :: IO ()
  27         , labelThread   -- :: ThreadId -> String -> IO ()
  28         , forkProcessPrim -- :: IO Int
  29         , forkProcess   -- :: IO (Maybe Int)
  30
  31         -- Waiting
  32         , threadDelay           -- :: Int -> IO ()
  33         , threadWaitRead        -- :: Int -> IO ()
  34         , threadWaitWrite       -- :: Int -> IO ()
  35
  36         -- MVars
  37         , MVar          -- abstract
  38         , newMVar       -- :: a -> IO (MVar a)
  39         , newEmptyMVar  -- :: IO (MVar a)
  40         , takeMVar      -- :: MVar a -> IO a
  41         , putMVar       -- :: MVar a -> a -> IO ()
  42         , tryTakeMVar   -- :: MVar a -> IO (Maybe a)
  43         , tryPutMVar    -- :: MVar a -> a -> IO Bool
  44         , isEmptyMVar   -- :: MVar a -> IO Bool
  45         , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
  46
  47     ) where
  48
  49 import Data.Maybe
  50
  51 import GHC.Base
  52 import GHC.IOBase       ( IO(..), MVar(..), ioException, IOException(..), IOErrorType(..) )
  53 import GHC.Num          ( fromInteger, negate )
  54 import GHC.Base         ( Int(..) )
  55 import GHC.Exception    ( Exception(..), AsyncException(..) )
  56 import GHC.Pack         ( packCString# )
  57
  58 infixr 0 `par`, `pseq`
  59 \end{code}
  60
  61 %************************************************************************
  62 %*                                                                      *
  63 \subsection{@ThreadId@, @par@, and @fork@}
  64 %*                                                                      *
  65 %************************************************************************
  66
  67 \begin{code}
  68 data ThreadId = ThreadId ThreadId#
  69 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
  70 -- But since ThreadId# is unlifted, the Weak type must use open
  71 -- type variables.
  72 {- ^
  73 A 'ThreadId' is an abstract type representing a handle to a thread.
  74 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
  75 the 'Ord' instance implements an arbitrary total ordering over
  76 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
  77 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
  78 useful when debugging or diagnosing the behaviour of a concurrent
  79 program.
  80
  81 NOTE: in GHC, if you have a 'ThreadId', you essentially have
  82 a pointer to the thread itself.  This means the thread itself can\'t be
  83 garbage collected until you drop the 'ThreadId'.
  84 This misfeature will hopefully be corrected at a later date.
  85 -}
  86
  87 --forkIO has now been hoisted out into the Concurrent library.
  88
  89 {- | 'killThread' terminates the given thread (Note: 'killThread' is
  90 not implemented in Hugs).  Any work already done by the thread isn\'t
  91 lost: the computation is suspended until required by another thread.
  92 The memory used by the thread will be garbage collected if it isn\'t
  93 referenced from anywhere.  The 'killThread' function is defined in
  94 terms of 'throwTo':
  95
  96 > killThread tid = throwTo tid (AsyncException ThreadKilled)
  97
  98 -}
  99 killThread :: ThreadId -> IO ()
 100 killThread tid = throwTo tid (AsyncException ThreadKilled)
 101
 102 {- | 'throwTo' raises an arbitrary exception in the target thread.
 103
 104 'throwTo' does not return until the exception has been raised in the
 105 target thread.  The calling thread can thus be certain that the target
 106 thread has received the exception.  This is a useful property to know
 107 when dealing with race conditions: eg. if there are two threads that
 108 can kill each other, it is guaranteed that only one of the threads
 109 will get to kill the other. -}
 110 throwTo :: ThreadId -> Exception -> IO ()
 111 throwTo (ThreadId id) ex = IO $ \ s ->
 112    case (killThread# id ex s) of s1 -> (# s1, () #)
 113
 114 -- | Returns the 'ThreadId' of the calling thread.
 115 myThreadId :: IO ThreadId
 116 myThreadId = IO $ \s ->
 117    case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
 118
 119
 120 -- |The 'yield' action allows (forces, in a co-operative multitasking
 121 -- implementation) a context-switch to any other currently runnable
 122 -- threads (if any), and is occasionally useful when implementing
 123 -- concurrency abstractions.
 124 yield :: IO ()
 125 yield = IO $ \s ->
 126    case (yield# s) of s1 -> (# s1, () #)
 127
 128 {- | 'labelThread' stores a string as identifier for this thread if
 129 you built a RTS with debugging support. This identifier will be used in
 130 the debugging output to make distinction of different threads easier
 131 (otherwise you only have the thread state object\'s address in the heap).
 132
 133 Other applications like the graphical Concurrent Haskell Debugger
 134 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
 135 'labelThread' for their purposes as well.
 136 -}
 137
 138 labelThread :: ThreadId -> String -> IO ()
 139 labelThread (ThreadId t) str = IO $ \ s ->
 140    let ps  = packCString# str
 141        adr = byteArrayContents# ps in
 142      case (labelThread# t adr s) of s1 -> (# s1, () #)
 143
 144 {- | This function is a replacement for "Posix.forkProcess": This implementation
 145 /will stop all other Concurrent Haskell threads/ in the (heavyweight) forked copy.
 146 'forkProcessPrim' returns the pid of the child process to the parent, 0 to the child,
 147 and a value less than 0 in case of errors. See also: 'forkProcess'.
 148
 149 Without this function, you need excessive and often impractical
 150 explicit synchronization using the regular Concurrent Haskell constructs to assure
 151 that only the desired thread is running after the fork().
 152
 153 The stopped threads are /not/ garbage collected! This behaviour may change in
 154 future releases.
 155 -}
 156
 157 forkProcessPrim :: IO Int
 158 forkProcessPrim = IO $ \s -> case (forkProcess# s) of (# s1, id #) -> (# s1, (I# id) #)
 159
 160 {- | 'forkProcess' is a wrapper around 'forkProcessPrim' similar to the one found in
 161 "Posix.forkProcess" which returns a Maybe-type. The child receives @Nothing@, the
 162 parent @Just (pid::Int)@. In case of an error, an exception is thrown.
 163 -}
 164
 165 forkProcess :: IO (Maybe Int)
 166 forkProcess = do
 167   pid <- forkProcessPrim
 168   case pid of
 169     -1 -> ioException (IOError Nothing      -- stolen from hslibs/posix/PosixUtil
 170                               SystemError
 171                               "forkProcess"
 172                               ""
 173                               Nothing)
 174     0  -> return Nothing
 175     _  -> return (Just pid)
 176
 177 --      Nota Bene: 'pseq' used to be 'seq'
 178 --                 but 'seq' is now defined in PrelGHC
 179 --
 180 -- "pseq" is defined a bit weirdly (see below)
 181 --
 182 -- The reason for the strange "lazy" call is that
 183 -- it fools the compiler into thinking that pseq  and par are non-strict in
 184 -- their second argument (even if it inlines pseq at the call site).
 185 -- If it thinks pseq is strict in "y", then it often evaluates
 186 -- "y" before "x", which is totally wrong.
 187
 188 {-# INLINE pseq  #-}
 189 pseq :: a -> b -> b
 190 pseq  x y = x `seq` lazy y
 191
 192 {-# INLINE par  #-}
 193 par :: a -> b -> b
 194 par  x y = case (par# x) of { _ -> lazy y }
 195 \end{code}
 196
 197 %************************************************************************
 198 %*                                                                      *
 199 \subsection[mvars]{M-Structures}
 200 %*                                                                      *
 201 %************************************************************************
 202
 203 M-Vars are rendezvous points for concurrent threads.  They begin
 204 empty, and any attempt to read an empty M-Var blocks.  When an M-Var
 205 is written, a single blocked thread may be freed.  Reading an M-Var
 206 toggles its state from full back to empty.  Therefore, any value
 207 written to an M-Var may only be read once.  Multiple reads and writes
 208 are allowed, but there must be at least one read between any two
 209 writes.
 210
 211 \begin{code}
 212 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
 213
 214 -- |Create an 'MVar' which is initially empty.
 215 newEmptyMVar  :: IO (MVar a)
 216 newEmptyMVar = IO $ \ s# ->
 217     case newMVar# s# of
 218          (# s2#, svar# #) -> (# s2#, MVar svar# #)
 219
 220 -- |Create an 'MVar' which contains the supplied value.
 221 newMVar :: a -> IO (MVar a)
 222 newMVar value =
 223     newEmptyMVar        >>= \ mvar ->
 224     putMVar mvar value  >>
 225     return mvar
 226
 227 -- |Return the contents of the 'MVar'.  If the 'MVar' is currently
 228 -- empty, 'takeMVar' will wait until it is full.  After a 'takeMVar',
 229 -- the 'MVar' is left empty.
 230 --
 231 -- If several threads are competing to take the same 'MVar', one is chosen
 232 -- to continue at random when the 'MVar' becomes full.
 233 takeMVar :: MVar a -> IO a
 234 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
 235
 236 -- |Put a value into an 'MVar'.  If the 'MVar' is currently full,
 237 -- 'putMVar' will wait until it becomes empty.
 238 --
 239 -- If several threads are competing to fill the same 'MVar', one is
 240 -- chosen to continue at random with the 'MVar' becomes empty.
 241 putMVar  :: MVar a -> a -> IO ()
 242 putMVar (MVar mvar#) x = IO $ \ s# ->
 243     case putMVar# mvar# x s# of
 244         s2# -> (# s2#, () #)
 245
 246 -- |A non-blocking version of 'takeMVar'.  The 'tryTakeMVar' function
 247 -- returns immediately, with 'Nothing' if the 'MVar' was empty, or
 248 -- @'Just' a@ if the 'MVar' was full with contents @a@.  After 'tryTakeMVar',
 249 -- the 'MVar' is left empty.
 250 tryTakeMVar :: MVar a -> IO (Maybe a)
 251 tryTakeMVar (MVar m) = IO $ \ s ->
 252     case tryTakeMVar# m s of
 253         (# s, 0#, _ #) -> (# s, Nothing #)      -- MVar is empty
 254         (# s, _,  a #) -> (# s, Just a  #)      -- MVar is full
 255
 256 -- |A non-blocking version of 'putMVar'.  The 'tryPutMVar' function
 257 -- attempts to put the value @a@ into the 'MVar', returning 'True' if
 258 -- it was successful, or 'False' otherwise.
 259 tryPutMVar  :: MVar a -> a -> IO Bool
 260 tryPutMVar (MVar mvar#) x = IO $ \ s# ->
 261     case tryPutMVar# mvar# x s# of
 262         (# s, 0# #) -> (# s, False #)
 263         (# s, _  #) -> (# s, True #)
 264
 265 -- |Check whether a given 'MVar' is empty.
 266 --
 267 -- Notice that the boolean value returned  is just a snapshot of
 268 -- the state of the MVar. By the time you get to react on its result,
 269 -- the MVar may have been filled (or emptied) - so be extremely
 270 -- careful when using this operation.   Use 'tryTakeMVar' instead if possible.
 271 isEmptyMVar :: MVar a -> IO Bool
 272 isEmptyMVar (MVar mv#) = IO $ \ s# ->
 273     case isEmptyMVar# mv# s# of
 274         (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
 275
 276 -- |Add a finalizer to an 'MVar'.  See "Foreign.ForeignPtr" and
 277 -- "System.Mem.Weak" for more about finalizers.
 278 addMVarFinalizer :: MVar a -> IO () -> IO ()
 279 addMVarFinalizer (MVar m) finalizer =
 280   IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
 281 \end{code}
 282
 283
 284 %************************************************************************
 285 %*                                                                      *
 286 \subsection{Thread waiting}
 287 %*                                                                      *
 288 %************************************************************************
 289
 290 @threadWaitRead@ delays rescheduling of a thread until input on the
 291 specified file descriptor is available for reading (just like select).
 292 @threadWaitWrite@ is similar, but for writing on a file descriptor.
 293
 294 \begin{code}
 295 -- |The 'threadDelay' operation will cause the current thread to
 296 -- suspend for a given number of microseconds.  Note that the resolution
 297 -- used by the Haskell runtime system\'s internal timer together with the
 298 -- fact that the thread may take some time to be rescheduled after the
 299 -- time has expired, means that the accuracy is more like 1\/50 second.
 300 threadDelay :: Int -> IO ()
 301
 302 -- | Block the current thread until data is available to read on the
 303 -- given file descriptor.
 304 threadWaitRead :: Int -> IO ()
 305
 306 -- | Block the current thread until data can be written to the
 307 -- given file descriptor.
 308 threadWaitWrite :: Int -> IO ()
 309
 310 threadDelay     (I# ms) = IO $ \s -> case delay# ms s     of s -> (# s, () #)
 311 threadWaitRead  (I# fd) = IO $ \s -> case waitRead# fd s  of s -> (# s, () #)
 312 threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #)
 313 \end{code}