2 {-# OPTIONS -fno-implicit-prelude #-}
3 -----------------------------------------------------------------------------
6 -- Copyright : (c) The University of Glasgow, 1994-2002
7 -- License : see libraries/base/LICENSE
9 -- Maintainer : cvs-ghc@haskell.org
10 -- Stability : internal
11 -- Portability : non-portable (GHC extensions)
13 -- Basic concurrency stuff.
15 -----------------------------------------------------------------------------
21 -- Forking and suchlike
22 , myThreadId -- :: IO ThreadId
23 , killThread -- :: ThreadId -> IO ()
24 , throwTo -- :: ThreadId -> Exception -> IO ()
25 , par -- :: a -> b -> b
26 , pseq -- :: a -> b -> b
28 , labelThread -- :: ThreadId -> String -> IO ()
29 , forkProcessPrim -- :: IO Int
30 , forkProcess -- :: IO (Maybe Int)
33 , threadDelay -- :: Int -> IO ()
34 , threadWaitRead -- :: Int -> IO ()
35 , threadWaitWrite -- :: Int -> IO ()
39 , newMVar -- :: a -> IO (MVar a)
40 , newEmptyMVar -- :: IO (MVar a)
41 , takeMVar -- :: MVar a -> IO a
42 , putMVar -- :: MVar a -> a -> IO ()
43 , tryTakeMVar -- :: MVar a -> IO (Maybe a)
44 , tryPutMVar -- :: MVar a -> a -> IO Bool
45 , isEmptyMVar -- :: MVar a -> IO Bool
46 , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
48 #ifdef mingw32_TARGET_OS
49 , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
50 , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
52 , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
53 , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
60 import GHC.IOBase ( IO(..), MVar(..), ioException, IOException(..), IOErrorType(..) )
61 import GHC.Num ( fromInteger, negate )
62 import GHC.Base ( Int(..) )
63 import GHC.Exception ( Exception(..), AsyncException(..) )
64 import GHC.Pack ( packCString# )
65 import GHC.Ptr ( Ptr(..), plusPtr )
67 infixr 0 `par`, `pseq`
70 %************************************************************************
72 \subsection{@ThreadId@, @par@, and @fork@}
74 %************************************************************************
77 data ThreadId = ThreadId ThreadId#
78 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
79 -- But since ThreadId# is unlifted, the Weak type must use open
82 A 'ThreadId' is an abstract type representing a handle to a thread.
83 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
84 the 'Ord' instance implements an arbitrary total ordering over
85 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
86 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
87 useful when debugging or diagnosing the behaviour of a concurrent
90 NOTE: in GHC, if you have a 'ThreadId', you essentially have
91 a pointer to the thread itself. This means the thread itself can\'t be
92 garbage collected until you drop the 'ThreadId'.
93 This misfeature will hopefully be corrected at a later date.
96 --forkIO has now been hoisted out into the Concurrent library.
98 {- | 'killThread' terminates the given thread (Note: 'killThread' is
99 not implemented in Hugs). Any work already done by the thread isn\'t
100 lost: the computation is suspended until required by another thread.
101 The memory used by the thread will be garbage collected if it isn\'t
102 referenced from anywhere. The 'killThread' function is defined in
105 > killThread tid = throwTo tid (AsyncException ThreadKilled)
108 killThread :: ThreadId -> IO ()
109 killThread tid = throwTo tid (AsyncException ThreadKilled)
111 {- | 'throwTo' raises an arbitrary exception in the target thread.
113 'throwTo' does not return until the exception has been raised in the
114 target thread. The calling thread can thus be certain that the target
115 thread has received the exception. This is a useful property to know
116 when dealing with race conditions: eg. if there are two threads that
117 can kill each other, it is guaranteed that only one of the threads
118 will get to kill the other. -}
119 throwTo :: ThreadId -> Exception -> IO ()
120 throwTo (ThreadId id) ex = IO $ \ s ->
121 case (killThread# id ex s) of s1 -> (# s1, () #)
123 -- | Returns the 'ThreadId' of the calling thread.
124 myThreadId :: IO ThreadId
125 myThreadId = IO $ \s ->
126 case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
129 -- |The 'yield' action allows (forces, in a co-operative multitasking
130 -- implementation) a context-switch to any other currently runnable
131 -- threads (if any), and is occasionally useful when implementing
132 -- concurrency abstractions.
135 case (yield# s) of s1 -> (# s1, () #)
137 {- | 'labelThread' stores a string as identifier for this thread if
138 you built a RTS with debugging support. This identifier will be used in
139 the debugging output to make distinction of different threads easier
140 (otherwise you only have the thread state object\'s address in the heap).
142 Other applications like the graphical Concurrent Haskell Debugger
143 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
144 'labelThread' for their purposes as well.
147 labelThread :: ThreadId -> String -> IO ()
148 labelThread (ThreadId t) str = IO $ \ s ->
149 let ps = packCString# str
150 adr = byteArrayContents# ps in
151 case (labelThread# t adr s) of s1 -> (# s1, () #)
153 {- | This function is a replacement for "Posix.forkProcess": This implementation
154 /will stop all other Concurrent Haskell threads/ in the (heavyweight) forked copy.
155 'forkProcessPrim' returns the pid of the child process to the parent, 0 to the child,
156 and a value less than 0 in case of errors. See also: 'forkProcess'.
158 Without this function, you need excessive and often impractical
159 explicit synchronization using the regular Concurrent Haskell constructs to assure
160 that only the desired thread is running after the fork().
162 The stopped threads are /not/ garbage collected! This behaviour may change in
165 NOTE: currently, main threads are not stopped in the child process.
166 To work around this problem, call 'forkProcessPrim' from the main thread.
169 forkProcessPrim :: IO Int
170 forkProcessPrim = IO $ \s -> case (forkProcess# s) of (# s1, id #) -> (# s1, (I# id) #)
172 {- | 'forkProcess' is a wrapper around 'forkProcessPrim' similar to the one found in
173 "Posix.forkProcess" which returns a Maybe-type. The child receives @Nothing@, the
174 parent @Just (pid::Int)@. In case of an error, an exception is thrown.
176 NOTE: currently, main threads are not stopped in the child process.
177 To work around this problem, call 'forkProcess' from the main thread.
180 forkProcess :: IO (Maybe Int)
182 pid <- forkProcessPrim
184 -1 -> ioException (IOError Nothing -- stolen from hslibs/posix/PosixUtil
190 _ -> return (Just pid)
192 -- Nota Bene: 'pseq' used to be 'seq'
193 -- but 'seq' is now defined in PrelGHC
195 -- "pseq" is defined a bit weirdly (see below)
197 -- The reason for the strange "lazy" call is that
198 -- it fools the compiler into thinking that pseq and par are non-strict in
199 -- their second argument (even if it inlines pseq at the call site).
200 -- If it thinks pseq is strict in "y", then it often evaluates
201 -- "y" before "x", which is totally wrong.
205 pseq x y = x `seq` lazy y
209 par x y = case (par# x) of { _ -> lazy y }
212 %************************************************************************
214 \subsection[mvars]{M-Structures}
216 %************************************************************************
218 M-Vars are rendezvous points for concurrent threads. They begin
219 empty, and any attempt to read an empty M-Var blocks. When an M-Var
220 is written, a single blocked thread may be freed. Reading an M-Var
221 toggles its state from full back to empty. Therefore, any value
222 written to an M-Var may only be read once. Multiple reads and writes
223 are allowed, but there must be at least one read between any two
227 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
229 -- |Create an 'MVar' which is initially empty.
230 newEmptyMVar :: IO (MVar a)
231 newEmptyMVar = IO $ \ s# ->
233 (# s2#, svar# #) -> (# s2#, MVar svar# #)
235 -- |Create an 'MVar' which contains the supplied value.
236 newMVar :: a -> IO (MVar a)
238 newEmptyMVar >>= \ mvar ->
239 putMVar mvar value >>
242 -- |Return the contents of the 'MVar'. If the 'MVar' is currently
243 -- empty, 'takeMVar' will wait until it is full. After a 'takeMVar',
244 -- the 'MVar' is left empty.
246 -- If several threads are competing to take the same 'MVar', one is chosen
247 -- to continue at random when the 'MVar' becomes full.
248 takeMVar :: MVar a -> IO a
249 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
251 -- |Put a value into an 'MVar'. If the 'MVar' is currently full,
252 -- 'putMVar' will wait until it becomes empty.
254 -- If several threads are competing to fill the same 'MVar', one is
255 -- chosen to continue at random with the 'MVar' becomes empty.
256 putMVar :: MVar a -> a -> IO ()
257 putMVar (MVar mvar#) x = IO $ \ s# ->
258 case putMVar# mvar# x s# of
261 -- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function
262 -- returns immediately, with 'Nothing' if the 'MVar' was empty, or
263 -- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar',
264 -- the 'MVar' is left empty.
265 tryTakeMVar :: MVar a -> IO (Maybe a)
266 tryTakeMVar (MVar m) = IO $ \ s ->
267 case tryTakeMVar# m s of
268 (# s, 0#, _ #) -> (# s, Nothing #) -- MVar is empty
269 (# s, _, a #) -> (# s, Just a #) -- MVar is full
271 -- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function
272 -- attempts to put the value @a@ into the 'MVar', returning 'True' if
273 -- it was successful, or 'False' otherwise.
274 tryPutMVar :: MVar a -> a -> IO Bool
275 tryPutMVar (MVar mvar#) x = IO $ \ s# ->
276 case tryPutMVar# mvar# x s# of
277 (# s, 0# #) -> (# s, False #)
278 (# s, _ #) -> (# s, True #)
280 -- |Check whether a given 'MVar' is empty.
282 -- Notice that the boolean value returned is just a snapshot of
283 -- the state of the MVar. By the time you get to react on its result,
284 -- the MVar may have been filled (or emptied) - so be extremely
285 -- careful when using this operation. Use 'tryTakeMVar' instead if possible.
286 isEmptyMVar :: MVar a -> IO Bool
287 isEmptyMVar (MVar mv#) = IO $ \ s# ->
288 case isEmptyMVar# mv# s# of
289 (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
291 -- |Add a finalizer to an 'MVar'. See "Foreign.ForeignPtr" and
292 -- "System.Mem.Weak" for more about finalizers.
293 addMVarFinalizer :: MVar a -> IO () -> IO ()
294 addMVarFinalizer (MVar m) finalizer =
295 IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
299 %************************************************************************
301 \subsection{Thread waiting}
303 %************************************************************************
305 @threadWaitRead@ delays rescheduling of a thread until input on the
306 specified file descriptor is available for reading (just like select).
307 @threadWaitWrite@ is similar, but for writing on a file descriptor.
310 -- |The 'threadDelay' operation will cause the current thread to
311 -- suspend for a given number of microseconds. Note that the resolution
312 -- used by the Haskell runtime system\'s internal timer together with the
313 -- fact that the thread may take some time to be rescheduled after the
314 -- time has expired, means that the accuracy is more like 1\/50 second.
315 threadDelay :: Int -> IO ()
317 -- | Block the current thread until data is available to read on the
318 -- given file descriptor.
319 threadWaitRead :: Int -> IO ()
321 -- | Block the current thread until data can be written to the
322 -- given file descriptor.
323 threadWaitWrite :: Int -> IO ()
325 threadDelay (I# ms) = IO $ \s -> case delay# ms s of s -> (# s, () #)
326 threadWaitRead (I# fd) = IO $ \s -> case waitRead# fd s of s -> (# s, () #)
327 threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #)
329 #ifdef mingw32_TARGET_OS
331 -- Note: threadDelay, threadWaitRead and threadWaitWrite aren't really functional
332 -- on Win32, but left in there because lib code (still) uses them (the manner
333 -- in which they're used doesn't cause problems on a Win32 platform though.)
335 asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
336 asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) =
337 IO $ \s -> case asyncRead# fd isSock len buf s of
338 (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
340 asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
341 asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
342 IO $ \s -> case asyncWrite# fd isSock len buf s of
343 (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
345 -- to aid the use of these primops by the IO Handle implementation,
346 -- provide the following convenience funs:
348 -- this better be a pinned byte array!
349 asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
350 asyncReadBA fd isSock len off bufB =
351 asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
353 asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
354 asyncWriteBA fd isSock len off bufB =
355 asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)