ghc/lib/ghc/ConcBase.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4
   5 \section[ConcBase]{Module @ConcBase@}
   6
   7 Basic concurrency stuff
   8
   9 \begin{code}
  10 {-# OPTIONS -fno-implicit-prelude #-}
  11 module ConcBase(
  12                 -- Forking and suchlike
  13         ST,     forkST,
  14         PrimIO, forkPrimIO,
  15         IO,     forkIO,
  16         par, fork,
  17         threadDelay, threadWaitRead, threadWaitWrite,
  18
  19                 -- MVars
  20         MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar
  21     ) where
  22
  23 import PrelBase
  24 import STBase   ( PrimIO(..), ST(..), STret(..), StateAndPtr#(..) )
  25 import IOBase   ( IO(..), IOResult(..), MVar(..) )
  26 import GHCerr   ( parError )
  27 import PrelBase ( Int(..) )
  28 import GHC      ( fork#, delay#, waitRead#, waitWrite#,
  29                   SynchVar#, newSynchVar#, takeMVar#, putMVar#,
  30                   State#, RealWorld, par#
  31                 )
  32
  33 infixr 0 `par`, `fork`
  34 \end{code}
  35
  36
  37
  38 %************************************************************************
  39 %*                                                                      *
  40 \subsection{@par@, and @fork@}
  41 %*                                                                      *
  42 %************************************************************************
  43
  44 \begin{code}
  45 forkST :: ST s a -> ST s a
  46
  47 forkST (ST action) = ST $ \ s ->
  48         let d@(STret _ r) = action s in
  49         d `fork` STret s r
  50
  51 forkPrimIO :: PrimIO a -> PrimIO a
  52 forkPrimIO = forkST
  53
  54 forkIO :: IO () -> IO ()
  55 forkIO (IO action) = IO $ \ s -> (action s) `fork` IOok s ()
  56
  57 par, fork :: Eval a => a -> b -> b
  58
  59 {-# INLINE par  #-}
  60 {-# INLINE fork #-}
  61
  62 #if defined(__PARALLEL_HASKELL__) || defined (__GRANSIM__)
  63 par  x y = case (par#  x) of { 0# -> parError; _ -> y }
  64 #else
  65 par  x y = y
  66 #endif
  67
  68 #if defined(__CONCURRENT_HASKELL__) || defined (__GRANSIM__)
  69 fork x y = case (fork# x) of { 0# -> parError; _ -> y }
  70 #else
  71 fork x y = y
  72 #endif
  73
  74 \end{code}
  75
  76 %************************************************************************
  77 %*                                                                      *
  78 \subsection[PreludeGlaST-mvars]{M-Structures}
  79 %*                                                                      *
  80 %************************************************************************
  81
  82 M-Vars are rendezvous points for concurrent threads.  They begin
  83 empty, and any attempt to read an empty M-Var blocks.  When an M-Var
  84 is written, a single blocked thread may be freed.  Reading an M-Var
  85 toggles its state from full back to empty.  Therefore, any value
  86 written to an M-Var may only be read once.  Multiple reads and writes
  87 are allowed, but there must be at least one read between any two
  88 writes.
  89
  90 \begin{code}
  91 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
  92
  93 newEmptyMVar  :: IO (MVar a)
  94
  95 newEmptyMVar = IO $ \ s# ->
  96     case newSynchVar# s# of
  97         StateAndSynchVar# s2# svar# -> IOok s2# (MVar svar#)
  98
  99 takeMVar :: MVar a -> IO a
 100
 101 takeMVar (MVar mvar#) = IO $ \ s# ->
 102     case takeMVar# mvar# s# of
 103         StateAndPtr# s2# r -> IOok s2# r
 104
 105 putMVar  :: MVar a -> a -> IO ()
 106
 107 putMVar (MVar mvar#) x = IO $ \ s# ->
 108     case putMVar# mvar# x s# of
 109         s2# -> IOok s2# ()
 110
 111 newMVar :: a -> IO (MVar a)
 112
 113 newMVar value =
 114     newEmptyMVar        >>= \ mvar ->
 115     putMVar mvar value  >>
 116     return mvar
 117
 118 readMVar :: MVar a -> IO a
 119
 120 readMVar mvar =
 121     takeMVar mvar       >>= \ value ->
 122     putMVar mvar value  >>
 123     return value
 124
 125 swapMVar :: MVar a -> a -> IO a
 126
 127 swapMVar mvar new =
 128     takeMVar mvar       >>= \ old ->
 129     putMVar mvar new    >>
 130     return old
 131 \end{code}
 132
 133
 134 %************************************************************************
 135 %*                                                                      *
 136 \subsection{Thread waiting}
 137 %*                                                                      *
 138 %************************************************************************
 139
 140 @threadDelay@ delays rescheduling of a thread until the indicated
 141 number of microseconds have elapsed.  Generally, the microseconds are
 142 counted by the context switch timer, which ticks in virtual time;
 143 however, when there are no runnable threads, we don't accumulate any
 144 virtual time, so we start ticking in real time.  (The granularity is
 145 the effective resolution of the context switch timer, so it is
 146 affected by the RTS -C option.)
 147
 148 @threadWaitRead@ delays rescheduling of a thread until input on the
 149 specified file descriptor is available for reading (just like select).
 150 @threadWaitWrite@ is similar, but for writing on a file descriptor.
 151
 152 \begin{code}
 153 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
 154
 155 threadDelay (I# x#) = IO $ \ s# ->
 156     case delay# x# s# of
 157       s2# -> IOok s2# ()
 158
 159 threadWaitRead (I# x#) = IO $ \ s# ->
 160     case waitRead# x# s# of
 161       s2# -> IOok s2# ()
 162
 163 threadWaitWrite (I# x#) = IO $ \ s# ->
 164     case waitWrite# x# s# of
 165       s2# -> IOok s2# ()
 166 \end{code}
 167
 168 %*********************************************************
 169 %*                                                      *
 170 \subsection{Ghastly return types}
 171 %*                                                      *
 172 %*********************************************************
 173
 174 \begin{code}
 175 data StateAndSynchVar# s elt = StateAndSynchVar# (State# s) (SynchVar# s elt)
 176 \end{code}