[project @ 2002-08-30 07:56:48 by stolz]
[packages/old-time.git] / GHC / Conc.lhs
1 \begin{code}
2 {-# OPTIONS -fno-implicit-prelude #-}
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module      :  GHC.Conc
6 -- Copyright   :  (c) The University of Glasgow, 1994-2002
7 -- License     :  see libraries/base/LICENSE
8 -- 
9 -- Maintainer  :  cvs-ghc@haskell.org
10 -- Stability   :  internal
11 -- Portability :  non-portable (GHC extensions)
12 --
13 -- Basic concurrency stuff.
14 -- 
15 -----------------------------------------------------------------------------
16
17 module GHC.Conc
18         ( ThreadId(..)
19
20         -- Forking and suchlike
21         , myThreadId    -- :: IO ThreadId
22         , killThread    -- :: ThreadId -> IO ()
23         , throwTo       -- :: ThreadId -> Exception -> IO ()
24         , par           -- :: a -> b -> b
25         , pseq          -- :: a -> b -> b
26         , yield         -- :: IO ()
27         , labelThread   -- :: ThreadId -> String -> IO ()
28         , forkProcessPrim -- :: IO Int
29         , forkProcess   -- :: IO (Maybe Int)
30
31         -- Waiting
32         , threadDelay           -- :: Int -> IO ()
33         , threadWaitRead        -- :: Int -> IO ()
34         , threadWaitWrite       -- :: Int -> IO ()
35
36         -- MVars
37         , MVar          -- abstract
38         , newMVar       -- :: a -> IO (MVar a)
39         , newEmptyMVar  -- :: IO (MVar a)
40         , takeMVar      -- :: MVar a -> IO a
41         , putMVar       -- :: MVar a -> a -> IO ()
42         , tryTakeMVar   -- :: MVar a -> IO (Maybe a)
43         , tryPutMVar    -- :: MVar a -> a -> IO Bool
44         , isEmptyMVar   -- :: MVar a -> IO Bool
45         , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
46
47     ) where
48
49 import Data.Maybe
50
51 import GHC.Base
52 import GHC.IOBase       ( IO(..), MVar(..), ioException, IOException(..), IOErrorType(..) )
53 import GHC.Num          ( fromInteger, negate )
54 import GHC.Base         ( Int(..) )
55 import GHC.Exception    ( Exception(..), AsyncException(..) )
56 import GHC.Pack         ( packCString# )
57
58 infixr 0 `par`, `pseq`
59 \end{code}
60
61 %************************************************************************
62 %*                                                                      *
63 \subsection{@ThreadId@, @par@, and @fork@}
64 %*                                                                      *
65 %************************************************************************
66
67 \begin{code}
68 data ThreadId = ThreadId ThreadId#
69 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
70 -- But since ThreadId# is unlifted, the Weak type must use open
71 -- type variables.
72 {- ^
73 A 'ThreadId' is an abstract type representing a handle to a thread.
74 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
75 the 'Ord' instance implements an arbitrary total ordering over
76 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
77 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
78 useful when debugging or diagnosing the behaviour of a concurrent
79 program.
80
81 NOTE: in GHC, if you have a 'ThreadId', you essentially have
82 a pointer to the thread itself.  This means the thread itself can\'t be
83 garbage collected until you drop the 'ThreadId'.
84 This misfeature will hopefully be corrected at a later date.
85 -}
86
87 --forkIO has now been hoisted out into the Concurrent library.
88
89 {- | 'killThread' terminates the given thread (Note: 'killThread' is
90 not implemented in Hugs).  Any work already done by the thread isn\'t
91 lost: the computation is suspended until required by another thread.
92 The memory used by the thread will be garbage collected if it isn\'t
93 referenced from anywhere.  The 'killThread' function may be defined in
94 terms of 'throwTo':
95
96 >   killThread tid = throwTo tid (AsyncException ThreadKilled)
97 -}
98 killThread :: ThreadId -> IO ()
99 killThread (ThreadId id) = IO $ \ s ->
100    case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #)
101
102 {- | 'throwTo' raises an arbitrary exception in the target thread.
103
104 'throwTo' does not return until the exception has been raised in the
105 target thread.  The calling thread can thus be certain that the target
106 thread has received the exception.  This is a useful property to know
107 when dealing with race conditions: eg. if there are two threads that
108 can kill each other, it is guaranteed that only one of the threads
109 will get to kill the other. -}
110 throwTo :: ThreadId -> Exception -> IO ()
111 throwTo (ThreadId id) ex = IO $ \ s ->
112    case (killThread# id ex s) of s1 -> (# s1, () #)
113
114 -- | Returns the 'ThreadId' of the calling thread.
115 myThreadId :: IO ThreadId
116 myThreadId = IO $ \s ->
117    case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
118
119
120 -- |The 'yield' action allows (forces, in a co-operative multitasking
121 -- implementation) a context-switch to any other currently runnable
122 -- threads (if any), and is occasionally useful when implementing
123 -- concurrency abstractions.
124 yield :: IO ()
125 yield = IO $ \s -> 
126    case (yield# s) of s1 -> (# s1, () #)
127
128 {- | 'labelThread' stores a string as identifier for this thread if
129 you built a RTS with debugging support. This identifier will be used in
130 the debugging output to make distinction of different threads easier
131 (otherwise you only have the thread state object\'s address in the heap).
132
133 Other applications like the graphical Concurrent Haskell Debugger
134 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
135 'labelThread' for their purposes as well.
136 -}
137
138 labelThread :: ThreadId -> String -> IO ()
139 labelThread (ThreadId t) str = IO $ \ s ->
140    let ps  = packCString# str
141        adr = byteArrayContents# ps in
142      case (labelThread# t adr s) of s1 -> (# s1, () #)
143
144 {- | This function is a replacement for "Posix.forkProcess": This implementation
145 /will stop all other Concurrent Haskell threads/ in the (heavyweight) forked copy.
146 'forkProcessPrim' returns the pid of the child process to the parent, 0 to the child,
147 and a value less than 0 in case of errors. See also: 'forkProcess'.
148
149 Without this function, you need excessive and often impractical
150 explicit synchronization using the regular Concurrent Haskell constructs to assure
151 that only the desired thread is running after the fork().
152
153 The stopped threads are /not/ garbage collected! This behaviour may change in
154 future releases.
155 -}
156
157 forkProcessPrim :: IO Int
158 forkProcessPrim = IO $ \s -> case (forkProcess# s) of (# s1, id #) -> (# s1, (I# id) #)
159
160 {- | 'forkProcess' is a wrapper around 'forkProcessPrim' similar to the one found in
161 "Posix.forkProcess" which returns a Maybe-type. The child receives @Nothing@, the
162 parent @Just (pid::Int)@. In case of an error, an exception is thrown.
163 -}
164
165 forkProcess :: IO (Maybe Int)
166 forkProcess = do
167   pid <- forkProcessPrim
168   case pid of
169     -1 -> ioException (IOError Nothing      -- stolen from hslibs/posix/PosixUtil
170                               SystemError
171                               "forkProcess"
172                               ""
173                               Nothing)
174     0  -> return Nothing
175     _  -> return (Just pid)
176
177 --      Nota Bene: 'pseq' used to be 'seq'
178 --                 but 'seq' is now defined in PrelGHC
179 --
180 -- "pseq" is defined a bit weirdly (see below)
181 --
182 -- The reason for the strange "lazy" call is that
183 -- it fools the compiler into thinking that pseq  and par are non-strict in
184 -- their second argument (even if it inlines pseq at the call site).
185 -- If it thinks pseq is strict in "y", then it often evaluates
186 -- "y" before "x", which is totally wrong.  
187
188 {-# INLINE pseq  #-}
189 pseq :: a -> b -> b
190 pseq  x y = x `seq` lazy y
191
192 {-# INLINE par  #-}
193 par :: a -> b -> b
194 par  x y = case (par# x) of { _ -> lazy y }
195 \end{code}
196
197 %************************************************************************
198 %*                                                                      *
199 \subsection[mvars]{M-Structures}
200 %*                                                                      *
201 %************************************************************************
202
203 M-Vars are rendezvous points for concurrent threads.  They begin
204 empty, and any attempt to read an empty M-Var blocks.  When an M-Var
205 is written, a single blocked thread may be freed.  Reading an M-Var
206 toggles its state from full back to empty.  Therefore, any value
207 written to an M-Var may only be read once.  Multiple reads and writes
208 are allowed, but there must be at least one read between any two
209 writes.
210
211 \begin{code}
212 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
213
214 -- |Create an 'MVar' which is initially empty.
215 newEmptyMVar  :: IO (MVar a)
216 newEmptyMVar = IO $ \ s# ->
217     case newMVar# s# of
218          (# s2#, svar# #) -> (# s2#, MVar svar# #)
219
220 -- |Create an 'MVar' which contains the supplied value.
221 newMVar :: a -> IO (MVar a)
222 newMVar value =
223     newEmptyMVar        >>= \ mvar ->
224     putMVar mvar value  >>
225     return mvar
226
227 -- |Return the contents of the 'MVar'.  If the 'MVar' is currently
228 -- empty, 'takeMVar' will wait until it is full.  After a 'takeMVar', 
229 -- the 'MVar' is left empty.
230 -- 
231 -- If several threads are competing to take the same 'MVar', one is chosen
232 -- to continue at random when the 'MVar' becomes full.
233 takeMVar :: MVar a -> IO a
234 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
235
236 -- |Put a value into an 'MVar'.  If the 'MVar' is currently full,
237 -- 'putMVar' will wait until it becomes empty.
238 --
239 -- If several threads are competing to fill the same 'MVar', one is
240 -- chosen to continue at random with the 'MVar' becomes empty.
241 putMVar  :: MVar a -> a -> IO ()
242 putMVar (MVar mvar#) x = IO $ \ s# ->
243     case putMVar# mvar# x s# of
244         s2# -> (# s2#, () #)
245
246 -- |A non-blocking version of 'takeMVar'.  The 'tryTakeMVar' function
247 -- returns immediately, with 'Nothing' if the 'MVar' was empty, or
248 -- @'Just' a@ if the 'MVar' was full with contents @a@.  After 'tryTakeMVar',
249 -- the 'MVar' is left empty.
250 tryTakeMVar :: MVar a -> IO (Maybe a)
251 tryTakeMVar (MVar m) = IO $ \ s ->
252     case tryTakeMVar# m s of
253         (# s, 0#, _ #) -> (# s, Nothing #)      -- MVar is empty
254         (# s, _,  a #) -> (# s, Just a  #)      -- MVar is full
255
256 -- |A non-blocking version of 'putMVar'.  The 'tryPutMVar' function
257 -- attempts to put the value @a@ into the 'MVar', returning 'True' if
258 -- it was successful, or 'False' otherwise.
259 tryPutMVar  :: MVar a -> a -> IO Bool
260 tryPutMVar (MVar mvar#) x = IO $ \ s# ->
261     case tryPutMVar# mvar# x s# of
262         (# s, 0# #) -> (# s, False #)
263         (# s, _  #) -> (# s, True #)
264
265 -- |Check whether a given 'MVar' is empty.
266 --
267 -- Notice that the boolean value returned  is just a snapshot of
268 -- the state of the MVar. By the time you get to react on its result,
269 -- the MVar may have been filled (or emptied) - so be extremely
270 -- careful when using this operation.   Use 'tryTakeMVar' instead if possible.
271 isEmptyMVar :: MVar a -> IO Bool
272 isEmptyMVar (MVar mv#) = IO $ \ s# -> 
273     case isEmptyMVar# mv# s# of
274         (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
275
276 -- |Add a finalizer to an 'MVar'.  See "Foreign.ForeignPtr" and
277 -- "System.Mem.Weak" for more about finalizers.
278 addMVarFinalizer :: MVar a -> IO () -> IO ()
279 addMVarFinalizer (MVar m) finalizer = 
280   IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
281 \end{code}
282
283
284 %************************************************************************
285 %*                                                                      *
286 \subsection{Thread waiting}
287 %*                                                                      *
288 %************************************************************************
289
290 @threadWaitRead@ delays rescheduling of a thread until input on the
291 specified file descriptor is available for reading (just like select).
292 @threadWaitWrite@ is similar, but for writing on a file descriptor.
293
294 \begin{code}
295 -- |The 'threadDelay' operation will cause the current thread to
296 -- suspend for a given number of microseconds.  Note that the resolution
297 -- used by the Haskell runtime system\'s internal timer together with the
298 -- fact that the thread may take some time to be rescheduled after the
299 -- time has expired, means that the accuracy is more like 1\/50 second.
300 threadDelay :: Int -> IO ()
301
302 -- | Block the current thread until data is available to read on the
303 -- given file descriptor.
304 threadWaitRead :: Int -> IO ()
305
306 -- | Block the current thread until data can be written to the
307 -- given file descriptor.
308 threadWaitWrite :: Int -> IO ()
309
310 threadDelay     (I# ms) = IO $ \s -> case delay# ms s     of s -> (# s, () #)
311 threadWaitRead  (I# fd) = IO $ \s -> case waitRead# fd s  of s -> (# s, () #)
312 threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #)
313 \end{code}