GHC/Conc.lhs

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