GHC/Conc.lhs

   1 % -----------------------------------------------------------------------------
   2 % $Id: Conc.lhs,v 1.3 2001/12/21 15:07:22 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         , pseq          -- :: 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`, `pseq`
  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 --      Nota Bene: 'pseq' used to be 'seq'
  85 --                 but 'seq' is now defined in PrelGHC
  86 --
  87 -- "pseq" is defined a bit weirdly (see below)
  88 --
  89 -- The reason for the strange "0# -> parError" case is that
  90 -- it fools the compiler into thinking that seq is non-strict in
  91 -- its second argument (even if it inlines seq at the call site).
  92 -- If it thinks seq is strict in "y", then it often evaluates
  93 -- "y" before "x", which is totally wrong.
  94 --
  95 -- Just before converting from Core to STG there's a bit of magic
  96 -- that recognises the seq# and eliminates the duff case.
  97
  98 {-# INLINE pseq  #-}
  99 pseq :: a -> b -> b
 100 pseq  x y = case (seq#  x) of { 0# -> seqError; _ -> y }
 101
 102 {-# INLINE par  #-}
 103 par :: a -> b -> b
 104 par  x y = case (par# x) of { 0# -> parError; _ -> y }
 105 \end{code}
 106
 107 %************************************************************************
 108 %*                                                                      *
 109 \subsection[mvars]{M-Structures}
 110 %*                                                                      *
 111 %************************************************************************
 112
 113 M-Vars are rendezvous points for concurrent threads.  They begin
 114 empty, and any attempt to read an empty M-Var blocks.  When an M-Var
 115 is written, a single blocked thread may be freed.  Reading an M-Var
 116 toggles its state from full back to empty.  Therefore, any value
 117 written to an M-Var may only be read once.  Multiple reads and writes
 118 are allowed, but there must be at least one read between any two
 119 writes.
 120
 121 \begin{code}
 122 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
 123
 124 newEmptyMVar  :: IO (MVar a)
 125 newEmptyMVar = IO $ \ s# ->
 126     case newMVar# s# of
 127          (# s2#, svar# #) -> (# s2#, MVar svar# #)
 128
 129 takeMVar :: MVar a -> IO a
 130 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
 131
 132 putMVar  :: MVar a -> a -> IO ()
 133 putMVar (MVar mvar#) x = IO $ \ s# ->
 134     case putMVar# mvar# x s# of
 135         s2# -> (# s2#, () #)
 136
 137 tryPutMVar  :: MVar a -> a -> IO Bool
 138 tryPutMVar (MVar mvar#) x = IO $ \ s# ->
 139     case tryPutMVar# mvar# x s# of
 140         (# s, 0# #) -> (# s, False #)
 141         (# s, _  #) -> (# s, True #)
 142
 143 newMVar :: a -> IO (MVar a)
 144 newMVar value =
 145     newEmptyMVar        >>= \ mvar ->
 146     putMVar mvar value  >>
 147     return mvar
 148
 149 -- tryTakeMVar is a non-blocking takeMVar
 150 tryTakeMVar :: MVar a -> IO (Maybe a)
 151 tryTakeMVar (MVar m) = IO $ \ s ->
 152     case tryTakeMVar# m s of
 153         (# s, 0#, _ #) -> (# s, Nothing #)      -- MVar is empty
 154         (# s, _,  a #) -> (# s, Just a  #)      -- MVar is full
 155
 156 {-
 157  Low-level op. for checking whether an MVar is filled-in or not.
 158  Notice that the boolean value returned  is just a snapshot of
 159  the state of the MVar. By the time you get to react on its result,
 160  the MVar may have been filled (or emptied) - so be extremely
 161  careful when using this operation.
 162
 163  Use tryTakeMVar instead if possible.
 164
 165  If you can re-work your abstractions to avoid having to
 166  depend on isEmptyMVar, then you're encouraged to do so,
 167  i.e., consider yourself warned about the imprecision in
 168  general of isEmptyMVar :-)
 169 -}
 170 isEmptyMVar :: MVar a -> IO Bool
 171 isEmptyMVar (MVar mv#) = IO $ \ s# ->
 172     case isEmptyMVar# mv# s# of
 173         (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
 174
 175 -- Like addForeignPtrFinalizer, but for MVars
 176 addMVarFinalizer :: MVar a -> IO () -> IO ()
 177 addMVarFinalizer (MVar m) finalizer =
 178   IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
 179 \end{code}
 180
 181
 182 %************************************************************************
 183 %*                                                                      *
 184 \subsection{Thread waiting}
 185 %*                                                                      *
 186 %************************************************************************
 187
 188 @threadDelay@ delays rescheduling of a thread until the indicated
 189 number of microseconds have elapsed.  Generally, the microseconds are
 190 counted by the context switch timer, which ticks in virtual time;
 191 however, when there are no runnable threads, we don't accumulate any
 192 virtual time, so we start ticking in real time.  (The granularity is
 193 the effective resolution of the context switch timer, so it is
 194 affected by the RTS -C option.)
 195
 196 @threadWaitRead@ delays rescheduling of a thread until input on the
 197 specified file descriptor is available for reading (just like select).
 198 @threadWaitWrite@ is similar, but for writing on a file descriptor.
 199
 200 \begin{code}
 201 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
 202
 203 threadDelay     (I# ms) = IO $ \s -> case delay# ms s     of s -> (# s, () #)
 204 threadWaitRead  (I# fd) = IO $ \s -> case waitRead# fd s  of s -> (# s, () #)
 205 threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #)
 206 \end{code}