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