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