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