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 {-# SOURCE #-} PrelErr ( parError )
  24 import PrelST           ( ST(..), STret(..), StateAndPtr#(..) )
  25 import PrelIOBase       ( IO(..), IOResult(..), MVar(..) )
  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 instance Eq (MVar a) where
  92         (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
  93
  94 newEmptyMVar  :: IO (MVar a)
  95
  96 newEmptyMVar = IO $ \ s# ->
  97     case newSynchVar# s# of
  98         StateAndSynchVar# s2# svar# -> IOok s2# (MVar svar#)
  99
 100 takeMVar :: MVar a -> IO a
 101
 102 takeMVar (MVar mvar#) = IO $ \ s# ->
 103     case takeMVar# mvar# s# of
 104         StateAndPtr# s2# r -> IOok s2# r
 105
 106 putMVar  :: MVar a -> a -> IO ()
 107
 108 putMVar (MVar mvar#) x = IO $ \ s# ->
 109     case putMVar# mvar# x s# of
 110         s2# -> IOok s2# ()
 111
 112 newMVar :: a -> IO (MVar a)
 113
 114 newMVar value =
 115     newEmptyMVar        >>= \ mvar ->
 116     putMVar mvar value  >>
 117     return mvar
 118
 119 readMVar :: MVar a -> IO a
 120
 121 readMVar mvar =
 122     takeMVar mvar       >>= \ value ->
 123     putMVar mvar value  >>
 124     return value
 125
 126 swapMVar :: MVar a -> a -> IO a
 127
 128 swapMVar mvar new =
 129     takeMVar mvar       >>= \ old ->
 130     putMVar mvar new    >>
 131     return old
 132 \end{code}
 133
 134
 135 %************************************************************************
 136 %*                                                                      *
 137 \subsection{Thread waiting}
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 @threadDelay@ delays rescheduling of a thread until the indicated
 142 number of microseconds have elapsed.  Generally, the microseconds are
 143 counted by the context switch timer, which ticks in virtual time;
 144 however, when there are no runnable threads, we don't accumulate any
 145 virtual time, so we start ticking in real time.  (The granularity is
 146 the effective resolution of the context switch timer, so it is
 147 affected by the RTS -C option.)
 148
 149 @threadWaitRead@ delays rescheduling of a thread until input on the
 150 specified file descriptor is available for reading (just like select).
 151 @threadWaitWrite@ is similar, but for writing on a file descriptor.
 152
 153 \begin{code}
 154 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
 155
 156 threadDelay (I# x#) = IO $ \ s# ->
 157     case delay# x# s# of
 158       s2# -> IOok s2# ()
 159
 160 threadWaitRead (I# x#) = IO $ \ s# ->
 161     case waitRead# x# s# of
 162       s2# -> IOok s2# ()
 163
 164 threadWaitWrite (I# x#) = IO $ \ s# ->
 165     case waitWrite# x# s# of
 166       s2# -> IOok 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}