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 ()
31 , threadDelay -- :: Int -> IO ()
32 , threadWaitRead -- :: Int -> IO ()
33 , threadWaitWrite -- :: Int -> IO ()
37 , newMVar -- :: a -> IO (MVar a)
38 , newEmptyMVar -- :: IO (MVar a)
39 , takeMVar -- :: MVar a -> IO a
40 , putMVar -- :: MVar a -> a -> IO ()
41 , tryTakeMVar -- :: MVar a -> IO (Maybe a)
42 , tryPutMVar -- :: MVar a -> a -> IO Bool
43 , isEmptyMVar -- :: MVar a -> IO Bool
44 , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
46 #ifdef mingw32_TARGET_OS
47 , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
48 , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
49 , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
51 , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
52 , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
59 import GHC.IOBase ( IO(..), MVar(..), ioException, IOException(..), IOErrorType(..) )
60 import GHC.Num ( fromInteger, negate )
61 import GHC.Real ( fromIntegral )
62 import GHC.Base ( Int(..) )
63 import GHC.Exception ( Exception(..), AsyncException(..) )
64 import GHC.Pack ( packCString# )
65 import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) )
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.
95 /Note/: Hugs does not provide any operations on other threads;
96 it defines 'ThreadId' as a synonym for ().
99 --forkIO has now been hoisted out into the Concurrent library.
101 {- | 'killThread' terminates the given thread (GHC only).
102 Any work already done by the thread isn\'t
103 lost: the computation is suspended until required by another thread.
104 The memory used by the thread will be garbage collected if it isn\'t
105 referenced from anywhere. The 'killThread' function is defined in
108 > killThread tid = throwTo tid (AsyncException ThreadKilled)
111 killThread :: ThreadId -> IO ()
112 killThread tid = throwTo tid (AsyncException ThreadKilled)
114 {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
116 'throwTo' does not return until the exception has been raised in the
117 target thread. The calling thread can thus be certain that the target
118 thread has received the exception. This is a useful property to know
119 when dealing with race conditions: eg. if there are two threads that
120 can kill each other, it is guaranteed that only one of the threads
121 will get to kill the other. -}
122 throwTo :: ThreadId -> Exception -> IO ()
123 throwTo (ThreadId id) ex = IO $ \ s ->
124 case (killThread# id ex s) of s1 -> (# s1, () #)
126 -- | Returns the 'ThreadId' of the calling thread (GHC only).
127 myThreadId :: IO ThreadId
128 myThreadId = IO $ \s ->
129 case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
132 -- |The 'yield' action allows (forces, in a co-operative multitasking
133 -- implementation) a context-switch to any other currently runnable
134 -- threads (if any), and is occasionally useful when implementing
135 -- concurrency abstractions.
138 case (yield# s) of s1 -> (# s1, () #)
140 {- | 'labelThread' stores a string as identifier for this thread if
141 you built a RTS with debugging support. This identifier will be used in
142 the debugging output to make distinction of different threads easier
143 (otherwise you only have the thread state object\'s address in the heap).
145 Other applications like the graphical Concurrent Haskell Debugger
146 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
147 'labelThread' for their purposes as well.
150 labelThread :: ThreadId -> String -> IO ()
151 labelThread (ThreadId t) str = IO $ \ s ->
152 let ps = packCString# str
153 adr = byteArrayContents# ps in
154 case (labelThread# t adr s) of s1 -> (# s1, () #)
156 -- Nota Bene: 'pseq' used to be 'seq'
157 -- but 'seq' is now defined in PrelGHC
159 -- "pseq" is defined a bit weirdly (see below)
161 -- The reason for the strange "lazy" call is that
162 -- it fools the compiler into thinking that pseq and par are non-strict in
163 -- their second argument (even if it inlines pseq at the call site).
164 -- If it thinks pseq is strict in "y", then it often evaluates
165 -- "y" before "x", which is totally wrong.
169 pseq x y = x `seq` lazy y
173 par x y = case (par# x) of { _ -> lazy y }
176 %************************************************************************
178 \subsection[mvars]{M-Structures}
180 %************************************************************************
182 M-Vars are rendezvous points for concurrent threads. They begin
183 empty, and any attempt to read an empty M-Var blocks. When an M-Var
184 is written, a single blocked thread may be freed. Reading an M-Var
185 toggles its state from full back to empty. Therefore, any value
186 written to an M-Var may only be read once. Multiple reads and writes
187 are allowed, but there must be at least one read between any two
191 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
193 -- |Create an 'MVar' which is initially empty.
194 newEmptyMVar :: IO (MVar a)
195 newEmptyMVar = IO $ \ s# ->
197 (# s2#, svar# #) -> (# s2#, MVar svar# #)
199 -- |Create an 'MVar' which contains the supplied value.
200 newMVar :: a -> IO (MVar a)
202 newEmptyMVar >>= \ mvar ->
203 putMVar mvar value >>
206 -- |Return the contents of the 'MVar'. If the 'MVar' is currently
207 -- empty, 'takeMVar' will wait until it is full. After a 'takeMVar',
208 -- the 'MVar' is left empty.
210 -- If several threads are competing to take the same 'MVar', one is chosen
211 -- to continue at random when the 'MVar' becomes full.
212 takeMVar :: MVar a -> IO a
213 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
215 -- |Put a value into an 'MVar'. If the 'MVar' is currently full,
216 -- 'putMVar' will wait until it becomes empty.
218 -- If several threads are competing to fill the same 'MVar', one is
219 -- chosen to continue at random with the 'MVar' becomes empty.
220 putMVar :: MVar a -> a -> IO ()
221 putMVar (MVar mvar#) x = IO $ \ s# ->
222 case putMVar# mvar# x s# of
225 -- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function
226 -- returns immediately, with 'Nothing' if the 'MVar' was empty, or
227 -- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar',
228 -- the 'MVar' is left empty.
229 tryTakeMVar :: MVar a -> IO (Maybe a)
230 tryTakeMVar (MVar m) = IO $ \ s ->
231 case tryTakeMVar# m s of
232 (# s, 0#, _ #) -> (# s, Nothing #) -- MVar is empty
233 (# s, _, a #) -> (# s, Just a #) -- MVar is full
235 -- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function
236 -- attempts to put the value @a@ into the 'MVar', returning 'True' if
237 -- it was successful, or 'False' otherwise.
238 tryPutMVar :: MVar a -> a -> IO Bool
239 tryPutMVar (MVar mvar#) x = IO $ \ s# ->
240 case tryPutMVar# mvar# x s# of
241 (# s, 0# #) -> (# s, False #)
242 (# s, _ #) -> (# s, True #)
244 -- |Check whether a given 'MVar' is empty.
246 -- Notice that the boolean value returned is just a snapshot of
247 -- the state of the MVar. By the time you get to react on its result,
248 -- the MVar may have been filled (or emptied) - so be extremely
249 -- careful when using this operation. Use 'tryTakeMVar' instead if possible.
250 isEmptyMVar :: MVar a -> IO Bool
251 isEmptyMVar (MVar mv#) = IO $ \ s# ->
252 case isEmptyMVar# mv# s# of
253 (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
255 -- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and
256 -- "System.Mem.Weak" for more about finalizers.
257 addMVarFinalizer :: MVar a -> IO () -> IO ()
258 addMVarFinalizer (MVar m) finalizer =
259 IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
263 %************************************************************************
265 \subsection{Thread waiting}
267 %************************************************************************
269 @threadWaitRead@ delays rescheduling of a thread until input on the
270 specified file descriptor is available for reading (just like select).
271 @threadWaitWrite@ is similar, but for writing on a file descriptor.
274 -- |The 'threadDelay' operation will cause the current thread to
275 -- suspend for a given number of microseconds (GHC only).
277 -- Note that the resolution
278 -- used by the Haskell runtime system\'s internal timer together with the
279 -- fact that the thread may take some time to be rescheduled after the
280 -- time has expired, means that the accuracy is more like 1\/50 second.
281 threadDelay :: Int -> IO ()
283 -- | Block the current thread until data is available to read on the
284 -- given file descriptor (GHC only).
285 threadWaitRead :: Int -> IO ()
287 -- | Block the current thread until data can be written to the
288 -- given file descriptor (GHC only).
289 threadWaitWrite :: Int -> IO ()
291 threadDelay (I# ms) = IO $ \s -> case delay# ms s of s -> (# s, () #)
292 threadWaitRead (I# fd) = IO $ \s -> case waitRead# fd s of s -> (# s, () #)
293 threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #)
295 #ifdef mingw32_TARGET_OS
297 -- Note: threadDelay, threadWaitRead and threadWaitWrite aren't really functional
298 -- on Win32, but left in there because lib code (still) uses them (the manner
299 -- in which they're used doesn't cause problems on a Win32 platform though.)
301 asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
302 asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) =
303 IO $ \s -> case asyncRead# fd isSock len buf s of
304 (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
306 asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
307 asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
308 IO $ \s -> case asyncWrite# fd isSock len buf s of
309 (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
311 asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
312 asyncDoProc (FunPtr proc) (Ptr param) =
313 -- the 'length' value is ignored; simplifies implementation of
314 -- the async*# primops to have them all return the same result.
315 IO $ \s -> case asyncDoProc# proc param s of
316 (# s, len#, err# #) -> (# s, I# err# #)
318 -- to aid the use of these primops by the IO Handle implementation,
319 -- provide the following convenience funs:
321 -- this better be a pinned byte array!
322 asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
323 asyncReadBA fd isSock len off bufB =
324 asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
326 asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
327 asyncWriteBA fd isSock len off bufB =
328 asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)