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