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