GHC/Conc.lhs

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