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