ghc/lib/std/PrelConc.lhs

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