ghc/lib/std/PrelConc.lhs

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