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