GHC/Conc.lhs

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