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