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