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
32 , threadDelay -- :: Int -> IO ()
33 , threadWaitRead -- :: Int -> IO ()
34 , threadWaitWrite -- :: Int -> IO ()
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 ()
47 #ifdef mingw32_TARGET_OS
48 , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
49 , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
50 , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO 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.Real ( fromIntegral )
63 import GHC.Base ( Int(..) )
64 import GHC.Exception ( Exception(..), AsyncException(..) )
65 import GHC.Pack ( packCString# )
66 import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) )
68 infixr 0 `par`, `pseq`
71 %************************************************************************
73 \subsection{@ThreadId@, @par@, and @fork@}
75 %************************************************************************
78 data ThreadId = ThreadId ThreadId#
79 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
80 -- But since ThreadId# is unlifted, the Weak type must use open
83 A 'ThreadId' is an abstract type representing a handle to a thread.
84 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
85 the 'Ord' instance implements an arbitrary total ordering over
86 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
87 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
88 useful when debugging or diagnosing the behaviour of a concurrent
91 /Note/: in GHC, if you have a 'ThreadId', you essentially have
92 a pointer to the thread itself. This means the thread itself can\'t be
93 garbage collected until you drop the 'ThreadId'.
94 This misfeature will hopefully be corrected at a later date.
96 /Note/: Hugs does not provide any operations on other threads;
97 it defines 'ThreadId' as a synonym for ().
100 --forkIO has now been hoisted out into the Concurrent library.
102 {- | 'killThread' terminates the given thread (GHC only).
103 Any work already done by the thread isn\'t
104 lost: the computation is suspended until required by another thread.
105 The memory used by the thread will be garbage collected if it isn\'t
106 referenced from anywhere. The 'killThread' function is defined in
109 > killThread tid = throwTo tid (AsyncException ThreadKilled)
112 killThread :: ThreadId -> IO ()
113 killThread tid = throwTo tid (AsyncException ThreadKilled)
115 {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
117 'throwTo' does not return until the exception has been raised in the
118 target thread. The calling thread can thus be certain that the target
119 thread has received the exception. This is a useful property to know
120 when dealing with race conditions: eg. if there are two threads that
121 can kill each other, it is guaranteed that only one of the threads
122 will get to kill the other. -}
123 throwTo :: ThreadId -> Exception -> IO ()
124 throwTo (ThreadId id) ex = IO $ \ s ->
125 case (killThread# id ex s) of s1 -> (# s1, () #)
127 -- | Returns the 'ThreadId' of the calling thread (GHC only).
128 myThreadId :: IO ThreadId
129 myThreadId = IO $ \s ->
130 case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
133 -- |The 'yield' action allows (forces, in a co-operative multitasking
134 -- implementation) a context-switch to any other currently runnable
135 -- threads (if any), and is occasionally useful when implementing
136 -- concurrency abstractions.
139 case (yield# s) of s1 -> (# s1, () #)
141 {- | 'labelThread' stores a string as identifier for this thread if
142 you built a RTS with debugging support. This identifier will be used in
143 the debugging output to make distinction of different threads easier
144 (otherwise you only have the thread state object\'s address in the heap).
146 Other applications like the graphical Concurrent Haskell Debugger
147 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
148 'labelThread' for their purposes as well.
151 labelThread :: ThreadId -> String -> IO ()
152 labelThread (ThreadId t) str = IO $ \ s ->
153 let ps = packCString# str
154 adr = byteArrayContents# ps in
155 case (labelThread# t adr s) of s1 -> (# s1, () #)
157 {- | This function is a replacement for 'System.Posix.Process.forkProcessAll':
158 This implementation /will stop all other Concurrent Haskell threads/ in the
159 (heavyweight) forked copy.
160 'forkProcessPrim' returns the pid of the child process to the parent, 0 to the
161 child, and a value less than 0 in case of errors. See also:
162 'System.Posix.Process.forkProcess' in package @unix@.
164 Without this function, you need excessive and often impractical
165 explicit synchronization using the regular Concurrent Haskell constructs to assure
166 that only the desired thread is running after the fork().
168 The stopped threads are /not/ garbage collected! This behaviour may change in
171 NOTE: currently, main threads are not stopped in the child process.
172 To work around this problem, call 'forkProcessPrim' from the main thread.
175 -- XXX RTS should know about 'pid_t'.
177 forkProcessPrim :: IO Int
178 forkProcessPrim = IO $ \s -> case (forkProcess# s) of (# s1, id #) -> (# s1, (I# id) #)
180 -- Nota Bene: 'pseq' used to be 'seq'
181 -- but 'seq' is now defined in PrelGHC
183 -- "pseq" is defined a bit weirdly (see below)
185 -- The reason for the strange "lazy" call is that
186 -- it fools the compiler into thinking that pseq and par are non-strict in
187 -- their second argument (even if it inlines pseq at the call site).
188 -- If it thinks pseq is strict in "y", then it often evaluates
189 -- "y" before "x", which is totally wrong.
193 pseq x y = x `seq` lazy y
197 par x y = case (par# x) of { _ -> lazy y }
200 %************************************************************************
202 \subsection[mvars]{M-Structures}
204 %************************************************************************
206 M-Vars are rendezvous points for concurrent threads. They begin
207 empty, and any attempt to read an empty M-Var blocks. When an M-Var
208 is written, a single blocked thread may be freed. Reading an M-Var
209 toggles its state from full back to empty. Therefore, any value
210 written to an M-Var may only be read once. Multiple reads and writes
211 are allowed, but there must be at least one read between any two
215 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
217 -- |Create an 'MVar' which is initially empty.
218 newEmptyMVar :: IO (MVar a)
219 newEmptyMVar = IO $ \ s# ->
221 (# s2#, svar# #) -> (# s2#, MVar svar# #)
223 -- |Create an 'MVar' which contains the supplied value.
224 newMVar :: a -> IO (MVar a)
226 newEmptyMVar >>= \ mvar ->
227 putMVar mvar value >>
230 -- |Return the contents of the 'MVar'. If the 'MVar' is currently
231 -- empty, 'takeMVar' will wait until it is full. After a 'takeMVar',
232 -- the 'MVar' is left empty.
234 -- If several threads are competing to take the same 'MVar', one is chosen
235 -- to continue at random when the 'MVar' becomes full.
236 takeMVar :: MVar a -> IO a
237 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
239 -- |Put a value into an 'MVar'. If the 'MVar' is currently full,
240 -- 'putMVar' will wait until it becomes empty.
242 -- If several threads are competing to fill the same 'MVar', one is
243 -- chosen to continue at random with the 'MVar' becomes empty.
244 putMVar :: MVar a -> a -> IO ()
245 putMVar (MVar mvar#) x = IO $ \ s# ->
246 case putMVar# mvar# x s# of
249 -- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function
250 -- returns immediately, with 'Nothing' if the 'MVar' was empty, or
251 -- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar',
252 -- the 'MVar' is left empty.
253 tryTakeMVar :: MVar a -> IO (Maybe a)
254 tryTakeMVar (MVar m) = IO $ \ s ->
255 case tryTakeMVar# m s of
256 (# s, 0#, _ #) -> (# s, Nothing #) -- MVar is empty
257 (# s, _, a #) -> (# s, Just a #) -- MVar is full
259 -- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function
260 -- attempts to put the value @a@ into the 'MVar', returning 'True' if
261 -- it was successful, or 'False' otherwise.
262 tryPutMVar :: MVar a -> a -> IO Bool
263 tryPutMVar (MVar mvar#) x = IO $ \ s# ->
264 case tryPutMVar# mvar# x s# of
265 (# s, 0# #) -> (# s, False #)
266 (# s, _ #) -> (# s, True #)
268 -- |Check whether a given 'MVar' is empty.
270 -- Notice that the boolean value returned is just a snapshot of
271 -- the state of the MVar. By the time you get to react on its result,
272 -- the MVar may have been filled (or emptied) - so be extremely
273 -- careful when using this operation. Use 'tryTakeMVar' instead if possible.
274 isEmptyMVar :: MVar a -> IO Bool
275 isEmptyMVar (MVar mv#) = IO $ \ s# ->
276 case isEmptyMVar# mv# s# of
277 (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
279 -- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and
280 -- "System.Mem.Weak" for more about finalizers.
281 addMVarFinalizer :: MVar a -> IO () -> IO ()
282 addMVarFinalizer (MVar m) finalizer =
283 IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
287 %************************************************************************
289 \subsection{Thread waiting}
291 %************************************************************************
293 @threadWaitRead@ delays rescheduling of a thread until input on the
294 specified file descriptor is available for reading (just like select).
295 @threadWaitWrite@ is similar, but for writing on a file descriptor.
298 -- |The 'threadDelay' operation will cause the current thread to
299 -- suspend for a given number of microseconds (GHC only).
301 -- Note that the resolution
302 -- used by the Haskell runtime system\'s internal timer together with the
303 -- fact that the thread may take some time to be rescheduled after the
304 -- time has expired, means that the accuracy is more like 1\/50 second.
305 threadDelay :: Int -> IO ()
307 -- | Block the current thread until data is available to read on the
308 -- given file descriptor (GHC only).
309 threadWaitRead :: Int -> IO ()
311 -- | Block the current thread until data can be written to the
312 -- given file descriptor (GHC only).
313 threadWaitWrite :: Int -> IO ()
315 threadDelay (I# ms) = IO $ \s -> case delay# ms s of s -> (# s, () #)
316 threadWaitRead (I# fd) = IO $ \s -> case waitRead# fd s of s -> (# s, () #)
317 threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #)
319 #ifdef mingw32_TARGET_OS
321 -- Note: threadDelay, threadWaitRead and threadWaitWrite aren't really functional
322 -- on Win32, but left in there because lib code (still) uses them (the manner
323 -- in which they're used doesn't cause problems on a Win32 platform though.)
325 asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
326 asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) =
327 IO $ \s -> case asyncRead# fd isSock len buf s of
328 (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
330 asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
331 asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
332 IO $ \s -> case asyncWrite# fd isSock len buf s of
333 (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
335 asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
336 asyncDoProc (FunPtr proc) (Ptr param) =
337 -- the 'length' value is ignored; simplifies implementation of
338 -- the async*# primops to have them all return the same result.
339 IO $ \s -> case asyncDoProc# proc param s of
340 (# s, len#, err# #) -> (# s, I# err# #)
342 -- to aid the use of these primops by the IO Handle implementation,
343 -- provide the following convenience funs:
345 -- this better be a pinned byte array!
346 asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
347 asyncReadBA fd isSock len off bufB =
348 asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
350 asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
351 asyncWriteBA fd isSock len off bufB =
352 asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)