ghc/lib/std/PrelConc.lhs

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