ghc/lib/std/PrelConc.lhs

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