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   -- :: String -> IO ()
  28         , forkProcess   -- :: IO Int
  29
  30         -- Waiting
  31         , threadDelay           -- :: Int -> IO ()
  32         , threadWaitRead        -- :: Int -> IO ()
  33         , threadWaitWrite       -- :: Int -> IO ()
  34
  35         -- MVars
  36         , MVar          -- abstract
  37         , newMVar       -- :: a -> IO (MVar a)
  38         , newEmptyMVar  -- :: IO (MVar a)
  39         , takeMVar      -- :: MVar a -> IO a
  40         , putMVar       -- :: MVar a -> a -> IO ()
  41         , tryTakeMVar   -- :: MVar a -> IO (Maybe a)
  42         , tryPutMVar    -- :: MVar a -> a -> IO Bool
  43         , isEmptyMVar   -- :: MVar a -> IO Bool
  44         , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
  45
  46     ) where
  47
  48 import Data.Maybe
  49
  50 import GHC.Base
  51 import GHC.Err          ( parError, seqError )
  52 import GHC.IOBase       ( IO(..), MVar(..) )
  53 import GHC.Base         ( Int(..) )
  54 import GHC.Exception    ( Exception(..), AsyncException(..) )
  55 import GHC.Pack         ( packCString# )
  56
  57 infixr 0 `par`, `pseq`
  58 \end{code}
  59
  60 %************************************************************************
  61 %*                                                                      *
  62 \subsection{@ThreadId@, @par@, and @fork@}
  63 %*                                                                      *
  64 %************************************************************************
  65
  66 \begin{code}
  67 data ThreadId = ThreadId ThreadId#
  68 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
  69 -- But since ThreadId# is unlifted, the Weak type must use open
  70 -- type variables.
  71 {- ^
  72 A 'ThreadId' is an abstract type representing a handle to a thread.
  73 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
  74 the 'Ord' instance implements an arbitrary total ordering over
  75 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
  76 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
  77 useful when debugging or diagnosing the behaviour of a concurrent
  78 program.
  79
  80 NOTE: in GHC, if you have a 'ThreadId', you essentially have
  81 a pointer to the thread itself.  This means the thread itself can\'t be
  82 garbage collected until you drop the 'ThreadId'.
  83 This misfeature will hopefully be corrected at a later date.
  84 -}
  85
  86 --forkIO has now been hoisted out into the Concurrent library.
  87
  88 {- | 'killThread' terminates the given thread (Note: 'killThread' is
  89 not implemented in Hugs).  Any work already done by the thread isn\'t
  90 lost: the computation is suspended until required by another thread.
  91 The memory used by the thread will be garbage collected if it isn\'t
  92 referenced from anywhere.  The 'killThread' function may be defined in
  93 terms of 'throwTo':
  94
  95 >   killThread = throwTo (AsyncException ThreadKilled)
  96 -}
  97 killThread :: ThreadId -> IO ()
  98 killThread (ThreadId id) = IO $ \ s ->
  99    case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #)
 100
 101 {- | 'throwTo' raises an arbitrary exception in the target thread.
 102
 103 'throwTo' does not return until the exception has been raised in the
 104 target thread.  The calling thread can thus be certain that the target
 105 thread has received the exception.  This is a useful property to know
 106 when dealing with race conditions: eg. if there are two threads that
 107 can kill each other, it is guaranteed that only one of the threads
 108 will get to kill the other. -}
 109 throwTo :: ThreadId -> Exception -> IO ()
 110 throwTo (ThreadId id) ex = IO $ \ s ->
 111    case (killThread# id ex s) of s1 -> (# s1, () #)
 112
 113 -- | Returns the 'ThreadId' of the calling thread.
 114 myThreadId :: IO ThreadId
 115 myThreadId = IO $ \s ->
 116    case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
 117
 118
 119 -- |The 'yield' action allows (forces, in a co-operative multitasking
 120 -- implementation) a context-switch to any other currently runnable
 121 -- threads (if any), and is occasionally useful when implementing
 122 -- concurrency abstractions.
 123 yield :: IO ()
 124 yield = IO $ \s ->
 125    case (yield# s) of s1 -> (# s1, () #)
 126
 127 labelThread :: String -> IO ()
 128 labelThread str = IO $ \ s ->
 129    let ps  = packCString# str
 130        adr = byteArrayContents# ps in
 131      case (labelThread# adr s) of s1 -> (# s1, () #)
 132
 133 forkProcess :: IO Int
 134 forkProcess = IO $ \s -> case (forkProcess# s) of (# s1, id #) -> (# s1, (I# id) #)
 135
 136 --      Nota Bene: 'pseq' used to be 'seq'
 137 --                 but 'seq' is now defined in PrelGHC
 138 --
 139 -- "pseq" is defined a bit weirdly (see below)
 140 --
 141 -- The reason for the strange "0# -> parError" case is that
 142 -- it fools the compiler into thinking that seq is non-strict in
 143 -- its second argument (even if it inlines seq at the call site).
 144 -- If it thinks seq is strict in "y", then it often evaluates
 145 -- "y" before "x", which is totally wrong.
 146 --
 147 -- Just before converting from Core to STG there's a bit of magic
 148 -- that recognises the seq# and eliminates the duff case.
 149
 150 {-# INLINE pseq  #-}
 151 pseq :: a -> b -> b
 152 pseq  x y = case (seq#  x) of { 0# -> seqError; _ -> y }
 153
 154 {-# INLINE par  #-}
 155 par :: a -> b -> b
 156 par  x y = case (par# x) of { 0# -> parError; _ -> y }
 157 \end{code}
 158
 159 %************************************************************************
 160 %*                                                                      *
 161 \subsection[mvars]{M-Structures}
 162 %*                                                                      *
 163 %************************************************************************
 164
 165 M-Vars are rendezvous points for concurrent threads.  They begin
 166 empty, and any attempt to read an empty M-Var blocks.  When an M-Var
 167 is written, a single blocked thread may be freed.  Reading an M-Var
 168 toggles its state from full back to empty.  Therefore, any value
 169 written to an M-Var may only be read once.  Multiple reads and writes
 170 are allowed, but there must be at least one read between any two
 171 writes.
 172
 173 \begin{code}
 174 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
 175
 176 -- |Create an 'MVar' which is initially empty.
 177 newEmptyMVar  :: IO (MVar a)
 178 newEmptyMVar = IO $ \ s# ->
 179     case newMVar# s# of
 180          (# s2#, svar# #) -> (# s2#, MVar svar# #)
 181
 182 -- |Create an 'MVar' which contains the supplied value.
 183 newMVar :: a -> IO (MVar a)
 184 newMVar value =
 185     newEmptyMVar        >>= \ mvar ->
 186     putMVar mvar value  >>
 187     return mvar
 188
 189 -- |Return the contents of the 'MVar'.  If the 'MVar' is currently
 190 -- empty, 'takeMVar' will wait until it is full.  After a 'takeMVar',
 191 -- the 'MVar' is left empty.
 192 --
 193 -- If several threads are competing to take the same 'MVar', one is chosen
 194 -- to continue at random when the 'MVar' becomes full.
 195 takeMVar :: MVar a -> IO a
 196 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
 197
 198 -- |Put a value into an 'MVar'.  If the 'MVar' is currently full,
 199 -- 'putMVar' will wait until it becomes empty.
 200 --
 201 -- If several threads are competing to fill the same 'MVar', one is
 202 -- chosen to continue at random with the 'MVar' becomes empty.
 203 putMVar  :: MVar a -> a -> IO ()
 204 putMVar (MVar mvar#) x = IO $ \ s# ->
 205     case putMVar# mvar# x s# of
 206         s2# -> (# s2#, () #)
 207
 208 -- |A non-blocking version of 'takeMVar'.  The 'tryTakeMVar' function
 209 -- returns immediately, with 'Nothing' if the 'MVar' was empty, or
 210 -- @'Just' a@ if the 'MVar' was full with contents @a@.  After 'tryTakeMVar',
 211 -- the 'MVar' is left empty.
 212 tryTakeMVar :: MVar a -> IO (Maybe a)
 213 tryTakeMVar (MVar m) = IO $ \ s ->
 214     case tryTakeMVar# m s of
 215         (# s, 0#, _ #) -> (# s, Nothing #)      -- MVar is empty
 216         (# s, _,  a #) -> (# s, Just a  #)      -- MVar is full
 217
 218 -- |A non-blocking version of 'putMVar'.  The 'tryPutMVar' function
 219 -- attempts to put the value @a@ into the 'MVar', returning 'True' if
 220 -- it was successful, or 'False' otherwise.
 221 tryPutMVar  :: MVar a -> a -> IO Bool
 222 tryPutMVar (MVar mvar#) x = IO $ \ s# ->
 223     case tryPutMVar# mvar# x s# of
 224         (# s, 0# #) -> (# s, False #)
 225         (# s, _  #) -> (# s, True #)
 226
 227 -- |Check whether a given 'MVar' is empty.
 228 --
 229 -- Notice that the boolean value returned  is just a snapshot of
 230 -- the state of the MVar. By the time you get to react on its result,
 231 -- the MVar may have been filled (or emptied) - so be extremely
 232 -- careful when using this operation.   Use 'tryTakeMVar' instead if possible.
 233 isEmptyMVar :: MVar a -> IO Bool
 234 isEmptyMVar (MVar mv#) = IO $ \ s# ->
 235     case isEmptyMVar# mv# s# of
 236         (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
 237
 238 -- |Add a finalizer to an 'MVar'.  See "Foreign.ForeignPtr" and
 239 -- "System.Mem.Weak" for more about finalizers.
 240 addMVarFinalizer :: MVar a -> IO () -> IO ()
 241 addMVarFinalizer (MVar m) finalizer =
 242   IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
 243 \end{code}
 244
 245
 246 %************************************************************************
 247 %*                                                                      *
 248 \subsection{Thread waiting}
 249 %*                                                                      *
 250 %************************************************************************
 251
 252 @threadWaitRead@ delays rescheduling of a thread until input on the
 253 specified file descriptor is available for reading (just like select).
 254 @threadWaitWrite@ is similar, but for writing on a file descriptor.
 255
 256 \begin{code}
 257 -- |The 'threadDelay' operation will cause the current thread to
 258 -- suspend for a given number of microseconds.  Note that the resolution
 259 -- used by the Haskell runtime system\'s internal timer together with the
 260 -- fact that the thread may take some time to be rescheduled after the
 261 -- time has expired, means that the accuracy is more like 1\/50 second.
 262 threadDelay :: Int -> IO ()
 263
 264 -- | Block the current thread until data is available to read on the
 265 -- given file descriptor.
 266 threadWaitRead :: Int -> IO ()
 267
 268 -- | Block the current thread until data can be written to the
 269 -- given file descriptor.
 270 threadWaitWrite :: Int -> IO ()
 271
 272 threadDelay     (I# ms) = IO $ \s -> case delay# ms s     of s -> (# s, () #)
 273 threadWaitRead  (I# fd) = IO $ \s -> case waitRead# fd s  of s -> (# s, () #)
 274 threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #)
 275 \end{code}