GHC/Conc.lhs

   1 % -----------------------------------------------------------------------------
   2 % $Id: Conc.lhs,v 1.4 2002/04/10 11:43:49 stolz Exp $
   3 %
   4 % (c) The University of Glasgow, 1994-2000
   5 %
   6
   7 \section[GHC.Conc]{Module @GHC.Conc@}
   8
   9 Basic concurrency stuff
  10
  11 \begin{code}
  12 {-# OPTIONS -fno-implicit-prelude #-}
  13
  14 module GHC.Conc
  15         ( ThreadId(..)
  16
  17         -- Forking and suchlike
  18         , myThreadId    -- :: IO ThreadId
  19         , killThread    -- :: ThreadId -> IO ()
  20         , throwTo       -- :: ThreadId -> Exception -> IO ()
  21         , par           -- :: a -> b -> b
  22         , pseq          -- :: a -> b -> b
  23         , yield         -- :: IO ()
  24         , labelThread   -- :: String -> IO ()
  25         , forkProcess   -- :: IO Int
  26
  27         -- Waiting
  28         , threadDelay           -- :: Int -> IO ()
  29         , threadWaitRead        -- :: Int -> IO ()
  30         , threadWaitWrite       -- :: Int -> IO ()
  31
  32         -- MVars
  33         , MVar          -- abstract
  34         , newMVar       -- :: a -> IO (MVar a)
  35         , newEmptyMVar  -- :: IO (MVar a)
  36         , takeMVar      -- :: MVar a -> IO a
  37         , putMVar       -- :: MVar a -> a -> IO ()
  38         , tryTakeMVar   -- :: MVar a -> IO (Maybe a)
  39         , tryPutMVar    -- :: MVar a -> a -> IO Bool
  40         , isEmptyMVar   -- :: MVar a -> IO Bool
  41         , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
  42
  43     ) where
  44
  45 import Data.Maybe
  46
  47 import GHC.Base
  48 import GHC.Err          ( parError, seqError )
  49 import GHC.IOBase       ( IO(..), MVar(..) )
  50 import GHC.Base         ( Int(..) )
  51 import GHC.Exception    ( Exception(..), AsyncException(..) )
  52 import GHC.Pack         ( packCString# )
  53
  54 infixr 0 `par`, `pseq`
  55 \end{code}
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 \subsection{@ThreadId@, @par@, and @fork@}
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 \begin{code}
  64 data ThreadId = ThreadId ThreadId#
  65 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
  66 -- But since ThreadId# is unlifted, the Weak type must use open
  67 -- type variables.
  68
  69 --forkIO has now been hoisted out into the Concurrent library.
  70
  71 killThread :: ThreadId -> IO ()
  72 killThread (ThreadId id) = IO $ \ s ->
  73    case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #)
  74
  75 throwTo :: ThreadId -> Exception -> IO ()
  76 throwTo (ThreadId id) ex = IO $ \ s ->
  77    case (killThread# id ex s) of s1 -> (# s1, () #)
  78
  79 myThreadId :: IO ThreadId
  80 myThreadId = IO $ \s ->
  81    case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
  82
  83 yield :: IO ()
  84 yield = IO $ \s ->
  85    case (yield# s) of s1 -> (# s1, () #)
  86
  87 labelThread :: String -> IO ()
  88 labelThread str = IO $ \ s ->
  89    let ps  = packCString# str
  90        adr = byteArrayContents# ps in
  91      case (labelThread# adr s) of s1 -> (# s1, () #)
  92
  93 forkProcess :: IO Int
  94 forkProcess = IO $ \s -> case (forkProcess# s) of (# s1, id #) -> (# s1, (I# id) #)
  95
  96 --      Nota Bene: 'pseq' used to be 'seq'
  97 --                 but 'seq' is now defined in PrelGHC
  98 --
  99 -- "pseq" is defined a bit weirdly (see below)
 100 --
 101 -- The reason for the strange "0# -> parError" case is that
 102 -- it fools the compiler into thinking that seq is non-strict in
 103 -- its second argument (even if it inlines seq at the call site).
 104 -- If it thinks seq is strict in "y", then it often evaluates
 105 -- "y" before "x", which is totally wrong.
 106 --
 107 -- Just before converting from Core to STG there's a bit of magic
 108 -- that recognises the seq# and eliminates the duff case.
 109
 110 {-# INLINE pseq  #-}
 111 pseq :: a -> b -> b
 112 pseq  x y = case (seq#  x) of { 0# -> seqError; _ -> y }
 113
 114 {-# INLINE par  #-}
 115 par :: a -> b -> b
 116 par  x y = case (par# x) of { 0# -> parError; _ -> y }
 117 \end{code}
 118
 119 %************************************************************************
 120 %*                                                                      *
 121 \subsection[mvars]{M-Structures}
 122 %*                                                                      *
 123 %************************************************************************
 124
 125 M-Vars are rendezvous points for concurrent threads.  They begin
 126 empty, and any attempt to read an empty M-Var blocks.  When an M-Var
 127 is written, a single blocked thread may be freed.  Reading an M-Var
 128 toggles its state from full back to empty.  Therefore, any value
 129 written to an M-Var may only be read once.  Multiple reads and writes
 130 are allowed, but there must be at least one read between any two
 131 writes.
 132
 133 \begin{code}
 134 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
 135
 136 newEmptyMVar  :: IO (MVar a)
 137 newEmptyMVar = IO $ \ s# ->
 138     case newMVar# s# of
 139          (# s2#, svar# #) -> (# s2#, MVar svar# #)
 140
 141 takeMVar :: MVar a -> IO a
 142 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
 143
 144 putMVar  :: MVar a -> a -> IO ()
 145 putMVar (MVar mvar#) x = IO $ \ s# ->
 146     case putMVar# mvar# x s# of
 147         s2# -> (# s2#, () #)
 148
 149 tryPutMVar  :: MVar a -> a -> IO Bool
 150 tryPutMVar (MVar mvar#) x = IO $ \ s# ->
 151     case tryPutMVar# mvar# x s# of
 152         (# s, 0# #) -> (# s, False #)
 153         (# s, _  #) -> (# s, True #)
 154
 155 newMVar :: a -> IO (MVar a)
 156 newMVar value =
 157     newEmptyMVar        >>= \ mvar ->
 158     putMVar mvar value  >>
 159     return mvar
 160
 161 -- tryTakeMVar is a non-blocking takeMVar
 162 tryTakeMVar :: MVar a -> IO (Maybe a)
 163 tryTakeMVar (MVar m) = IO $ \ s ->
 164     case tryTakeMVar# m s of
 165         (# s, 0#, _ #) -> (# s, Nothing #)      -- MVar is empty
 166         (# s, _,  a #) -> (# s, Just a  #)      -- MVar is full
 167
 168 {-
 169  Low-level op. for checking whether an MVar is filled-in or not.
 170  Notice that the boolean value returned  is just a snapshot of
 171  the state of the MVar. By the time you get to react on its result,
 172  the MVar may have been filled (or emptied) - so be extremely
 173  careful when using this operation.
 174
 175  Use tryTakeMVar instead if possible.
 176
 177  If you can re-work your abstractions to avoid having to
 178  depend on isEmptyMVar, then you're encouraged to do so,
 179  i.e., consider yourself warned about the imprecision in
 180  general of isEmptyMVar :-)
 181 -}
 182 isEmptyMVar :: MVar a -> IO Bool
 183 isEmptyMVar (MVar mv#) = IO $ \ s# ->
 184     case isEmptyMVar# mv# s# of
 185         (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
 186
 187 -- Like addForeignPtrFinalizer, but for MVars
 188 addMVarFinalizer :: MVar a -> IO () -> IO ()
 189 addMVarFinalizer (MVar m) finalizer =
 190   IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
 191 \end{code}
 192
 193
 194 %************************************************************************
 195 %*                                                                      *
 196 \subsection{Thread waiting}
 197 %*                                                                      *
 198 %************************************************************************
 199
 200 @threadDelay@ delays rescheduling of a thread until the indicated
 201 number of microseconds have elapsed.  Generally, the microseconds are
 202 counted by the context switch timer, which ticks in virtual time;
 203 however, when there are no runnable threads, we don't accumulate any
 204 virtual time, so we start ticking in real time.  (The granularity is
 205 the effective resolution of the context switch timer, so it is
 206 affected by the RTS -C option.)
 207
 208 @threadWaitRead@ delays rescheduling of a thread until input on the
 209 specified file descriptor is available for reading (just like select).
 210 @threadWaitWrite@ is similar, but for writing on a file descriptor.
 211
 212 \begin{code}
 213 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
 214
 215 threadDelay     (I# ms) = IO $ \s -> case delay# ms s     of s -> (# s, () #)
 216 threadWaitRead  (I# fd) = IO $ \s -> case waitRead# fd s  of s -> (# s, () #)
 217 threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #)
 218 \end{code}