2 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
3 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
4 {-# OPTIONS_HADDOCK not-home #-}
5 -----------------------------------------------------------------------------
8 -- Copyright : (c) The University of Glasgow, 1994-2002
9 -- License : see libraries/base/LICENSE
11 -- Maintainer : cvs-ghc@haskell.org
12 -- Stability : internal
13 -- Portability : non-portable (GHC extensions)
15 -- Basic concurrency stuff.
17 -----------------------------------------------------------------------------
19 -- No: #hide, because bits of this module are exposed by the stm package.
20 -- However, we don't want this module to be the home location for the
21 -- bits it exports, we'd rather have Control.Concurrent and the other
22 -- higher level modules be the home. Hence:
30 -- * Forking and suchlike
31 , forkIO -- :: IO a -> IO ThreadId
32 , forkOnIO -- :: Int -> IO a -> IO ThreadId
33 , numCapabilities -- :: Int
34 , childHandler -- :: Exception -> IO ()
35 , myThreadId -- :: IO ThreadId
36 , killThread -- :: ThreadId -> IO ()
37 , throwTo -- :: ThreadId -> Exception -> IO ()
38 , par -- :: a -> b -> b
39 , pseq -- :: a -> b -> b
42 , labelThread -- :: ThreadId -> String -> IO ()
44 , ThreadStatus(..), BlockReason(..)
45 , threadStatus -- :: ThreadId -> IO ThreadStatus
48 , threadDelay -- :: Int -> IO ()
49 , registerDelay -- :: Int -> IO (TVar Bool)
50 , threadWaitRead -- :: Int -> IO ()
51 , threadWaitWrite -- :: Int -> IO ()
55 , newMVar -- :: a -> IO (MVar a)
56 , newEmptyMVar -- :: IO (MVar a)
57 , takeMVar -- :: MVar a -> IO a
58 , putMVar -- :: MVar a -> a -> IO ()
59 , tryTakeMVar -- :: MVar a -> IO (Maybe a)
60 , tryPutMVar -- :: MVar a -> a -> IO Bool
61 , isEmptyMVar -- :: MVar a -> IO Bool
62 , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
66 , atomically -- :: STM a -> IO a
68 , orElse -- :: STM a -> STM a -> STM a
69 , catchSTM -- :: STM a -> (Exception -> STM a) -> STM a
70 , alwaysSucceeds -- :: STM a -> STM ()
71 , always -- :: STM Bool -> STM ()
73 , newTVar -- :: a -> STM (TVar a)
74 , newTVarIO -- :: a -> STM (TVar a)
75 , readTVar -- :: TVar a -> STM a
76 , readTVarIO -- :: TVar a -> IO a
77 , writeTVar -- :: a -> TVar a -> STM ()
78 , unsafeIOToSTM -- :: IO a -> STM a
81 #ifdef mingw32_HOST_OS
82 , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
83 , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
84 , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
86 , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
87 , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
90 #ifndef mingw32_HOST_OS
91 , Signal, HandlerFun, setHandler, runHandlers
94 , ensureIOManagerIsRunning
97 #ifdef mingw32_HOST_OS
100 , toWin32ConsoleEvent
102 , setUncaughtExceptionHandler -- :: (Exception -> IO ()) -> IO ()
103 , getUncaughtExceptionHandler -- :: IO (Exception -> IO ())
105 , reportError, reportStackOverflow
108 import System.Posix.Types
109 #ifndef mingw32_HOST_OS
110 import System.Posix.Internals
120 import {-# SOURCE #-} GHC.Handle
122 import GHC.Num ( Num(..) )
123 import GHC.Real ( fromIntegral )
124 import GHC.Arr ( inRange )
125 #ifdef mingw32_HOST_OS
126 import GHC.Real ( div )
127 import GHC.Ptr ( plusPtr, FunPtr(..) )
129 #ifdef mingw32_HOST_OS
130 import GHC.Read ( Read )
131 import GHC.Enum ( Enum )
133 import GHC.Exception ( SomeException(..), throw )
134 import GHC.Pack ( packCString# )
135 import GHC.Ptr ( Ptr(..) )
137 import GHC.Show ( Show(..), showString )
141 infixr 0 `par`, `pseq`
144 %************************************************************************
146 \subsection{@ThreadId@, @par@, and @fork@}
148 %************************************************************************
151 data ThreadId = ThreadId ThreadId# deriving( Typeable )
152 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
153 -- But since ThreadId# is unlifted, the Weak type must use open
156 A 'ThreadId' is an abstract type representing a handle to a thread.
157 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
158 the 'Ord' instance implements an arbitrary total ordering over
159 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
160 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
161 useful when debugging or diagnosing the behaviour of a concurrent
164 /Note/: in GHC, if you have a 'ThreadId', you essentially have
165 a pointer to the thread itself. This means the thread itself can\'t be
166 garbage collected until you drop the 'ThreadId'.
167 This misfeature will hopefully be corrected at a later date.
169 /Note/: Hugs does not provide any operations on other threads;
170 it defines 'ThreadId' as a synonym for ().
173 instance Show ThreadId where
175 showString "ThreadId " .
176 showsPrec d (getThreadId (id2TSO t))
178 foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
180 id2TSO :: ThreadId -> ThreadId#
181 id2TSO (ThreadId t) = t
183 foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
186 cmpThread :: ThreadId -> ThreadId -> Ordering
188 case cmp_thread (id2TSO t1) (id2TSO t2) of
193 instance Eq ThreadId where
195 case t1 `cmpThread` t2 of
199 instance Ord ThreadId where
203 Sparks off a new thread to run the 'IO' computation passed as the
204 first argument, and returns the 'ThreadId' of the newly created
207 The new thread will be a lightweight thread; if you want to use a foreign
208 library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead.
210 GHC note: the new thread inherits the /blocked/ state of the parent
211 (see 'Control.Exception.block').
213 The newly created thread has an exception handler that discards the
214 exceptions 'BlockedOnDeadMVar', 'BlockedIndefinitely', and
215 'ThreadKilled', and passes all other exceptions to the uncaught
216 exception handler (see 'setUncaughtExceptionHandler').
218 forkIO :: IO () -> IO ThreadId
219 forkIO action = IO $ \ s ->
220 case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
222 action_plus = catchException action childHandler
225 Like 'forkIO', but lets you specify on which CPU the thread is
226 created. Unlike a `forkIO` thread, a thread created by `forkOnIO`
227 will stay on the same CPU for its entire lifetime (`forkIO` threads
228 can migrate between CPUs according to the scheduling policy).
229 `forkOnIO` is useful for overriding the scheduling policy when you
230 know in advance how best to distribute the threads.
232 The `Int` argument specifies the CPU number; it is interpreted modulo
233 'numCapabilities' (note that it actually specifies a capability number
234 rather than a CPU number, but to a first approximation the two are
237 forkOnIO :: Int -> IO () -> IO ThreadId
238 forkOnIO (I# cpu) action = IO $ \ s ->
239 case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
241 action_plus = catchException action childHandler
243 -- | the value passed to the @+RTS -N@ flag. This is the number of
244 -- Haskell threads that can run truly simultaneously at any given
245 -- time, and is typically set to the number of physical CPU cores on
247 numCapabilities :: Int
248 numCapabilities = unsafePerformIO $ do
249 n <- peek n_capabilities
250 return (fromIntegral n)
252 #if defined(mingw32_HOST_OS) && defined(__PIC__)
253 foreign import ccall "_imp__n_capabilities" n_capabilities :: Ptr CInt
255 foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt
257 childHandler :: SomeException -> IO ()
258 childHandler err = catchException (real_handler err) childHandler
260 real_handler :: SomeException -> IO ()
261 real_handler se@(SomeException ex) =
262 -- ignore thread GC and killThread exceptions:
264 Just BlockedOnDeadMVar -> return ()
266 Just BlockedIndefinitely -> return ()
268 Just ThreadKilled -> return ()
270 -- report all others:
271 Just StackOverflow -> reportStackOverflow
274 {- | 'killThread' terminates the given thread (GHC only).
275 Any work already done by the thread isn\'t
276 lost: the computation is suspended until required by another thread.
277 The memory used by the thread will be garbage collected if it isn\'t
278 referenced from anywhere. The 'killThread' function is defined in
281 > killThread tid = throwTo tid ThreadKilled
283 Killthread is a no-op if the target thread has already completed.
285 killThread :: ThreadId -> IO ()
286 killThread tid = throwTo tid ThreadKilled
288 {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
290 'throwTo' does not return until the exception has been raised in the
292 The calling thread can thus be certain that the target
293 thread has received the exception. This is a useful property to know
294 when dealing with race conditions: eg. if there are two threads that
295 can kill each other, it is guaranteed that only one of the threads
296 will get to kill the other.
298 If the target thread is currently making a foreign call, then the
299 exception will not be raised (and hence 'throwTo' will not return)
300 until the call has completed. This is the case regardless of whether
301 the call is inside a 'block' or not.
303 Important note: the behaviour of 'throwTo' differs from that described in
304 the paper \"Asynchronous exceptions in Haskell\"
305 (<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>).
306 In the paper, 'throwTo' is non-blocking; but the library implementation adopts
307 a more synchronous design in which 'throwTo' does not return until the exception
308 is received by the target thread. The trade-off is discussed in Section 9 of the paper.
309 Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of
312 There is currently no guarantee that the exception delivered by 'throwTo' will be
313 delivered at the first possible opportunity. In particular, a thread may
314 unblock and then re-block exceptions (using 'unblock' and 'block') without receiving
315 a pending 'throwTo'. This is arguably undesirable behaviour.
318 throwTo :: Exception e => ThreadId -> e -> IO ()
319 throwTo (ThreadId tid) ex = IO $ \ s ->
320 case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)
322 -- | Returns the 'ThreadId' of the calling thread (GHC only).
323 myThreadId :: IO ThreadId
324 myThreadId = IO $ \s ->
325 case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)
328 -- |The 'yield' action allows (forces, in a co-operative multitasking
329 -- implementation) a context-switch to any other currently runnable
330 -- threads (if any), and is occasionally useful when implementing
331 -- concurrency abstractions.
334 case (yield# s) of s1 -> (# s1, () #)
336 {- | 'labelThread' stores a string as identifier for this thread if
337 you built a RTS with debugging support. This identifier will be used in
338 the debugging output to make distinction of different threads easier
339 (otherwise you only have the thread state object\'s address in the heap).
341 Other applications like the graphical Concurrent Haskell Debugger
342 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
343 'labelThread' for their purposes as well.
346 labelThread :: ThreadId -> String -> IO ()
347 labelThread (ThreadId t) str = IO $ \ s ->
348 let ps = packCString# str
349 adr = byteArrayContents# ps in
350 case (labelThread# t adr s) of s1 -> (# s1, () #)
352 -- Nota Bene: 'pseq' used to be 'seq'
353 -- but 'seq' is now defined in PrelGHC
355 -- "pseq" is defined a bit weirdly (see below)
357 -- The reason for the strange "lazy" call is that
358 -- it fools the compiler into thinking that pseq and par are non-strict in
359 -- their second argument (even if it inlines pseq at the call site).
360 -- If it thinks pseq is strict in "y", then it often evaluates
361 -- "y" before "x", which is totally wrong.
365 pseq x y = x `seq` lazy y
369 par x y = case (par# x) of { _ -> lazy y }
371 -- | Internal function used by the RTS to run sparks.
374 where loop s = case getSpark# s of
376 if n ==# 0# then (# s', () #)
381 -- ^blocked on on 'MVar'
383 -- ^blocked on a computation in progress by another thread
385 -- ^blocked in 'throwTo'
387 -- ^blocked in 'retry' in an STM transaction
388 | BlockedOnForeignCall
389 -- ^currently in a foreign call
391 -- ^blocked on some other resource. Without @-threaded@,
392 -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
393 -- they show up as 'BlockedOnMVar'.
394 deriving (Eq,Ord,Show)
396 -- | The current status of a thread
399 -- ^the thread is currently runnable or running
401 -- ^the thread has finished
402 | ThreadBlocked BlockReason
403 -- ^the thread is blocked on some resource
405 -- ^the thread received an uncaught exception
406 deriving (Eq,Ord,Show)
408 threadStatus :: ThreadId -> IO ThreadStatus
409 threadStatus (ThreadId t) = IO $ \s ->
410 case threadStatus# t s of
411 (# s', stat #) -> (# s', mk_stat (I# stat) #)
413 -- NB. keep these in sync with includes/Constants.h
414 mk_stat 0 = ThreadRunning
415 mk_stat 1 = ThreadBlocked BlockedOnMVar
416 mk_stat 2 = ThreadBlocked BlockedOnBlackHole
417 mk_stat 3 = ThreadBlocked BlockedOnException
418 mk_stat 7 = ThreadBlocked BlockedOnSTM
419 mk_stat 11 = ThreadBlocked BlockedOnForeignCall
420 mk_stat 12 = ThreadBlocked BlockedOnForeignCall
421 mk_stat 16 = ThreadFinished
422 mk_stat 17 = ThreadDied
423 mk_stat _ = ThreadBlocked BlockedOnOther
427 %************************************************************************
429 \subsection[stm]{Transactional heap operations}
431 %************************************************************************
433 TVars are shared memory locations which support atomic memory
437 -- |A monad supporting atomic memory transactions.
438 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
440 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
443 INSTANCE_TYPEABLE1(STM,stmTc,"STM")
445 instance Functor STM where
446 fmap f x = x >>= (return . f)
448 instance Monad STM where
449 {-# INLINE return #-}
453 return x = returnSTM x
454 m >>= k = bindSTM m k
456 bindSTM :: STM a -> (a -> STM b) -> STM b
457 bindSTM (STM m) k = STM ( \s ->
459 (# new_s, a #) -> unSTM (k a) new_s
462 thenSTM :: STM a -> STM b -> STM b
463 thenSTM (STM m) k = STM ( \s ->
465 (# new_s, _ #) -> unSTM k new_s
468 returnSTM :: a -> STM a
469 returnSTM x = STM (\s -> (# s, x #))
471 -- | Unsafely performs IO in the STM monad. Beware: this is a highly
472 -- dangerous thing to do.
474 -- * The STM implementation will often run transactions multiple
475 -- times, so you need to be prepared for this if your IO has any
478 -- * The STM implementation will abort transactions that are known to
479 -- be invalid and need to be restarted. This may happen in the middle
480 -- of `unsafeIOToSTM`, so make sure you don't acquire any resources
481 -- that need releasing (exception handlers are ignored when aborting
482 -- the transaction). That includes doing any IO using Handles, for
483 -- example. Getting this wrong will probably lead to random deadlocks.
485 -- * The transaction may have seen an inconsistent view of memory when
486 -- the IO runs. Invariants that you expect to be true throughout
487 -- your program may not be true inside a transaction, due to the
488 -- way transactions are implemented. Normally this wouldn't be visible
489 -- to the programmer, but using `unsafeIOToSTM` can expose it.
491 unsafeIOToSTM :: IO a -> STM a
492 unsafeIOToSTM (IO m) = STM m
494 -- |Perform a series of STM actions atomically.
496 -- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.
497 -- Any attempt to do so will result in a runtime error. (Reason: allowing
498 -- this would effectively allow a transaction inside a transaction, depending
499 -- on exactly when the thunk is evaluated.)
501 -- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',
502 -- and which allows top-level TVars to be allocated.
504 atomically :: STM a -> IO a
505 atomically (STM m) = IO (\s -> (atomically# m) s )
507 -- |Retry execution of the current memory transaction because it has seen
508 -- values in TVars which mean that it should not continue (e.g. the TVars
509 -- represent a shared buffer that is now empty). The implementation may
510 -- block the thread until one of the TVars that it has read from has been
511 -- udpated. (GHC only)
513 retry = STM $ \s# -> retry# s#
515 -- |Compose two alternative STM actions (GHC only). If the first action
516 -- completes without retrying then it forms the result of the orElse.
517 -- Otherwise, if the first action retries, then the second action is
518 -- tried in its place. If both actions retry then the orElse as a
520 orElse :: STM a -> STM a -> STM a
521 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
523 -- |Exception handling within STM actions.
524 catchSTM :: STM a -> (SomeException -> STM a) -> STM a
525 catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s
527 -- | Low-level primitive on which always and alwaysSucceeds are built.
528 -- checkInv differs form these in that (i) the invariant is not
529 -- checked when checkInv is called, only at the end of this and
530 -- subsequent transcations, (ii) the invariant failure is indicated
531 -- by raising an exception.
532 checkInv :: STM a -> STM ()
533 checkInv (STM m) = STM (\s -> (check# m) s)
535 -- | alwaysSucceeds adds a new invariant that must be true when passed
536 -- to alwaysSucceeds, at the end of the current transaction, and at
537 -- the end of every subsequent transaction. If it fails at any
538 -- of those points then the transaction violating it is aborted
539 -- and the exception raised by the invariant is propagated.
540 alwaysSucceeds :: STM a -> STM ()
541 alwaysSucceeds i = do ( do i ; retry ) `orElse` ( return () )
544 -- | always is a variant of alwaysSucceeds in which the invariant is
545 -- expressed as an STM Bool action that must return True. Returning
546 -- False or raising an exception are both treated as invariant failures.
547 always :: STM Bool -> STM ()
548 always i = alwaysSucceeds ( do v <- i
549 if (v) then return () else ( error "Transacional invariant violation" ) )
551 -- |Shared memory locations that support atomic memory transactions.
552 data TVar a = TVar (TVar# RealWorld a)
554 INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")
556 instance Eq (TVar a) where
557 (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
559 -- |Create a new TVar holding a value supplied
560 newTVar :: a -> STM (TVar a)
561 newTVar val = STM $ \s1# ->
562 case newTVar# val s1# of
563 (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
565 -- |@IO@ version of 'newTVar'. This is useful for creating top-level
566 -- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
567 -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
569 newTVarIO :: a -> IO (TVar a)
570 newTVarIO val = IO $ \s1# ->
571 case newTVar# val s1# of
572 (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
574 -- |Return the current value stored in a TVar.
575 -- This is equivalent to
577 -- > readTVarIO = atomically . readTVar
579 -- but works much faster, because it doesn't perform a complete
580 -- transaction, it just reads the current value of the 'TVar'.
581 readTVarIO :: TVar a -> IO a
582 readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s#
584 -- |Return the current value stored in a TVar
585 readTVar :: TVar a -> STM a
586 readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
588 -- |Write the supplied value into a TVar
589 writeTVar :: TVar a -> a -> STM ()
590 writeTVar (TVar tvar#) val = STM $ \s1# ->
591 case writeTVar# tvar# val s1# of
596 %************************************************************************
598 \subsection[mvars]{M-Structures}
600 %************************************************************************
602 M-Vars are rendezvous points for concurrent threads. They begin
603 empty, and any attempt to read an empty M-Var blocks. When an M-Var
604 is written, a single blocked thread may be freed. Reading an M-Var
605 toggles its state from full back to empty. Therefore, any value
606 written to an M-Var may only be read once. Multiple reads and writes
607 are allowed, but there must be at least one read between any two
611 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
613 -- |Create an 'MVar' which is initially empty.
614 newEmptyMVar :: IO (MVar a)
615 newEmptyMVar = IO $ \ s# ->
617 (# s2#, svar# #) -> (# s2#, MVar svar# #)
619 -- |Create an 'MVar' which contains the supplied value.
620 newMVar :: a -> IO (MVar a)
622 newEmptyMVar >>= \ mvar ->
623 putMVar mvar value >>
626 -- |Return the contents of the 'MVar'. If the 'MVar' is currently
627 -- empty, 'takeMVar' will wait until it is full. After a 'takeMVar',
628 -- the 'MVar' is left empty.
630 -- There are two further important properties of 'takeMVar':
632 -- * 'takeMVar' is single-wakeup. That is, if there are multiple
633 -- threads blocked in 'takeMVar', and the 'MVar' becomes full,
634 -- only one thread will be woken up. The runtime guarantees that
635 -- the woken thread completes its 'takeMVar' operation.
637 -- * When multiple threads are blocked on an 'MVar', they are
638 -- woken up in FIFO order. This is useful for providing
639 -- fairness properties of abstractions built using 'MVar's.
641 takeMVar :: MVar a -> IO a
642 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
644 -- |Put a value into an 'MVar'. If the 'MVar' is currently full,
645 -- 'putMVar' will wait until it becomes empty.
647 -- There are two further important properties of 'putMVar':
649 -- * 'putMVar' is single-wakeup. That is, if there are multiple
650 -- threads blocked in 'putMVar', and the 'MVar' becomes empty,
651 -- only one thread will be woken up. The runtime guarantees that
652 -- the woken thread completes its 'putMVar' operation.
654 -- * When multiple threads are blocked on an 'MVar', they are
655 -- woken up in FIFO order. This is useful for providing
656 -- fairness properties of abstractions built using 'MVar's.
658 putMVar :: MVar a -> a -> IO ()
659 putMVar (MVar mvar#) x = IO $ \ s# ->
660 case putMVar# mvar# x s# of
663 -- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function
664 -- returns immediately, with 'Nothing' if the 'MVar' was empty, or
665 -- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar',
666 -- the 'MVar' is left empty.
667 tryTakeMVar :: MVar a -> IO (Maybe a)
668 tryTakeMVar (MVar m) = IO $ \ s ->
669 case tryTakeMVar# m s of
670 (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty
671 (# s', _, a #) -> (# s', Just a #) -- MVar is full
673 -- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function
674 -- attempts to put the value @a@ into the 'MVar', returning 'True' if
675 -- it was successful, or 'False' otherwise.
676 tryPutMVar :: MVar a -> a -> IO Bool
677 tryPutMVar (MVar mvar#) x = IO $ \ s# ->
678 case tryPutMVar# mvar# x s# of
679 (# s, 0# #) -> (# s, False #)
680 (# s, _ #) -> (# s, True #)
682 -- |Check whether a given 'MVar' is empty.
684 -- Notice that the boolean value returned is just a snapshot of
685 -- the state of the MVar. By the time you get to react on its result,
686 -- the MVar may have been filled (or emptied) - so be extremely
687 -- careful when using this operation. Use 'tryTakeMVar' instead if possible.
688 isEmptyMVar :: MVar a -> IO Bool
689 isEmptyMVar (MVar mv#) = IO $ \ s# ->
690 case isEmptyMVar# mv# s# of
691 (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
693 -- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and
694 -- "System.Mem.Weak" for more about finalizers.
695 addMVarFinalizer :: MVar a -> IO () -> IO ()
696 addMVarFinalizer (MVar m) finalizer =
697 IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) }
701 %************************************************************************
703 \subsection{Thread waiting}
705 %************************************************************************
708 #ifdef mingw32_HOST_OS
710 -- Note: threadWaitRead and threadWaitWrite aren't really functional
711 -- on Win32, but left in there because lib code (still) uses them (the manner
712 -- in which they're used doesn't cause problems on a Win32 platform though.)
714 asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
715 asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) =
716 IO $ \s -> case asyncRead# fd isSock len buf s of
717 (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)
719 asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
720 asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
721 IO $ \s -> case asyncWrite# fd isSock len buf s of
722 (# s', len#, err# #) -> (# s', (I# len#, I# err#) #)
724 asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
725 asyncDoProc (FunPtr proc) (Ptr param) =
726 -- the 'length' value is ignored; simplifies implementation of
727 -- the async*# primops to have them all return the same result.
728 IO $ \s -> case asyncDoProc# proc param s of
729 (# s', _len#, err# #) -> (# s', I# err# #)
731 -- to aid the use of these primops by the IO Handle implementation,
732 -- provide the following convenience funs:
734 -- this better be a pinned byte array!
735 asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
736 asyncReadBA fd isSock len off bufB =
737 asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
739 asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
740 asyncWriteBA fd isSock len off bufB =
741 asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
745 -- -----------------------------------------------------------------------------
748 -- | Block the current thread until data is available to read on the
749 -- given file descriptor (GHC only).
750 threadWaitRead :: Fd -> IO ()
752 #ifndef mingw32_HOST_OS
753 | threaded = waitForReadEvent fd
755 | otherwise = IO $ \s ->
756 case fromIntegral fd of { I# fd# ->
757 case waitRead# fd# s of { s' -> (# s', () #)
760 -- | Block the current thread until data can be written to the
761 -- given file descriptor (GHC only).
762 threadWaitWrite :: Fd -> IO ()
764 #ifndef mingw32_HOST_OS
765 | threaded = waitForWriteEvent fd
767 | otherwise = IO $ \s ->
768 case fromIntegral fd of { I# fd# ->
769 case waitWrite# fd# s of { s' -> (# s', () #)
772 -- | Suspends the current thread for a given number of microseconds
775 -- There is no guarantee that the thread will be rescheduled promptly
776 -- when the delay has expired, but the thread will never continue to
777 -- run /earlier/ than specified.
779 threadDelay :: Int -> IO ()
781 | threaded = waitForDelayEvent time
782 | otherwise = IO $ \s ->
783 case fromIntegral time of { I# time# ->
784 case delay# time# s of { s' -> (# s', () #)
788 -- | Set the value of returned TVar to True after a given number of
789 -- microseconds. The caveats associated with threadDelay also apply.
791 registerDelay :: Int -> IO (TVar Bool)
793 | threaded = waitForDelayEventSTM usecs
794 | otherwise = error "registerDelay: requires -threaded"
796 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
798 waitForDelayEvent :: Int -> IO ()
799 waitForDelayEvent usecs = do
801 target <- calculateTarget usecs
802 atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
806 -- Delays for use in STM
807 waitForDelayEventSTM :: Int -> IO (TVar Bool)
808 waitForDelayEventSTM usecs = do
809 t <- atomically $ newTVar False
810 target <- calculateTarget usecs
811 atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))
815 calculateTarget :: Int -> IO USecs
816 calculateTarget usecs = do
818 return $ now + (fromIntegral usecs)
821 -- ----------------------------------------------------------------------------
822 -- Threaded RTS implementation of threadWaitRead, threadWaitWrite, threadDelay
824 -- In the threaded RTS, we employ a single IO Manager thread to wait
825 -- for all outstanding IO requests (threadWaitRead,threadWaitWrite)
826 -- and delays (threadDelay).
828 -- We can do this because in the threaded RTS the IO Manager can make
829 -- a non-blocking call to select(), so we don't have to do select() in
830 -- the scheduler as we have to in the non-threaded RTS. We get performance
831 -- benefits from doing it this way, because we only have to restart the select()
832 -- when a new request arrives, rather than doing one select() each time
833 -- around the scheduler loop. Furthermore, the scheduler can be simplified
834 -- by not having to check for completed IO requests.
836 -- Issues, possible problems:
838 -- - we might want bound threads to just do the blocking
839 -- operation rather than communicating with the IO manager
840 -- thread. This would prevent simgle-threaded programs which do
841 -- IO from requiring multiple OS threads. However, it would also
842 -- prevent bound threads waiting on IO from being killed or sent
845 -- - Apprently exec() doesn't work on Linux in a multithreaded program.
846 -- I couldn't repeat this.
848 -- - How do we handle signal delivery in the multithreaded RTS?
850 -- - forkProcess will kill the IO manager thread. Let's just
851 -- hope we don't need to do any blocking IO between fork & exec.
853 #ifndef mingw32_HOST_OS
855 = Read {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
856 | Write {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
860 = Delay {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())
861 | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
863 #ifndef mingw32_HOST_OS
864 pendingEvents :: IORef [IOReq]
866 pendingDelays :: IORef [DelayReq]
867 -- could use a strict list or array here
868 {-# NOINLINE pendingEvents #-}
869 {-# NOINLINE pendingDelays #-}
870 (pendingEvents,pendingDelays) = unsafePerformIO $ do
875 -- the first time we schedule an IO request, the service thread
876 -- will be created (cool, huh?)
878 ensureIOManagerIsRunning :: IO ()
879 ensureIOManagerIsRunning
880 | threaded = seq pendingEvents $ return ()
881 | otherwise = return ()
883 insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
884 insertDelay d [] = [d]
885 insertDelay d1 ds@(d2 : rest)
886 | delayTime d1 <= delayTime d2 = d1 : ds
887 | otherwise = d2 : insertDelay d1 rest
889 delayTime :: DelayReq -> USecs
890 delayTime (Delay t _) = t
891 delayTime (DelaySTM t _) = t
895 -- XXX: move into GHC.IOBase from Data.IORef?
896 atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b
897 atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s
899 foreign import ccall unsafe "getUSecOfDay"
900 getUSecOfDay :: IO USecs
902 prodding :: IORef Bool
903 {-# NOINLINE prodding #-}
904 prodding = unsafePerformIO (newIORef False)
906 prodServiceThread :: IO ()
907 prodServiceThread = do
908 was_set <- atomicModifyIORef prodding (\a -> (True,a))
909 if (not (was_set)) then wakeupIOManager else return ()
911 #ifdef mingw32_HOST_OS
912 -- ----------------------------------------------------------------------------
913 -- Windows IO manager thread
915 startIOManagerThread :: IO ()
916 startIOManagerThread = do
917 wakeup <- c_getIOManagerEvent
918 forkIO $ service_loop wakeup []
921 service_loop :: HANDLE -- read end of pipe
922 -> [DelayReq] -- current delay requests
925 service_loop wakeup old_delays = do
926 -- pick up new delay requests
927 new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
928 let delays = foldr insertDelay old_delays new_delays
931 (delays', timeout) <- getDelay now delays
933 r <- c_WaitForSingleObject wakeup timeout
935 0xffffffff -> do c_maperrno; throwErrno "service_loop"
937 r2 <- c_readIOManagerEvent
940 _ | r2 == io_MANAGER_WAKEUP -> return False
941 _ | r2 == io_MANAGER_DIE -> return True
942 0 -> return False -- spurious wakeup
943 _ -> do start_console_handler (r2 `shiftR` 1); return False
946 else service_cont wakeup delays'
948 _other -> service_cont wakeup delays' -- probably timeout
950 service_cont :: HANDLE -> [DelayReq] -> IO ()
951 service_cont wakeup delays = do
952 atomicModifyIORef prodding (\_ -> (False,False))
953 service_loop wakeup delays
955 -- must agree with rts/win32/ThrIOManager.c
956 io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32
957 io_MANAGER_WAKEUP = 0xffffffff
958 io_MANAGER_DIE = 0xfffffffe
964 -- these are sent to Services only.
967 deriving (Eq, Ord, Enum, Show, Read, Typeable)
969 start_console_handler :: Word32 -> IO ()
970 start_console_handler r =
971 case toWin32ConsoleEvent r of
972 Just x -> withMVar win32ConsoleHandler $ \handler -> do
977 toWin32ConsoleEvent :: Num a => a -> Maybe ConsoleEvent
978 toWin32ConsoleEvent ev =
980 0 {- CTRL_C_EVENT-} -> Just ControlC
981 1 {- CTRL_BREAK_EVENT-} -> Just Break
982 2 {- CTRL_CLOSE_EVENT-} -> Just Close
983 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff
984 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
987 win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
988 win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
990 -- XXX Is this actually needed?
991 stick :: IORef HANDLE
992 {-# NOINLINE stick #-}
993 stick = unsafePerformIO (newIORef nullPtr)
995 wakeupIOManager :: IO ()
997 _hdl <- readIORef stick
998 c_sendIOManagerEvent io_MANAGER_WAKEUP
1000 -- Walk the queue of pending delays, waking up any that have passed
1001 -- and return the smallest delay to wait for. The queue of pending
1002 -- delays is kept ordered.
1003 getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
1004 getDelay _ [] = return ([], iNFINITE)
1005 getDelay now all@(d : rest)
1007 Delay time m | now >= time -> do
1010 DelaySTM time t | now >= time -> do
1011 atomically $ writeTVar t True
1014 -- delay is in millisecs for WaitForSingleObject
1015 let micro_seconds = delayTime d - now
1016 milli_seconds = (micro_seconds + 999) `div` 1000
1017 in return (all, fromIntegral milli_seconds)
1019 -- ToDo: this just duplicates part of System.Win32.Types, which isn't
1020 -- available yet. We should move some Win32 functionality down here,
1021 -- maybe as part of the grand reorganisation of the base package...
1022 type HANDLE = Ptr ()
1026 iNFINITE = 0xFFFFFFFF -- urgh
1028 foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
1029 c_getIOManagerEvent :: IO HANDLE
1031 foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
1032 c_readIOManagerEvent :: IO Word32
1034 foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
1035 c_sendIOManagerEvent :: Word32 -> IO ()
1037 foreign import ccall unsafe "maperrno" -- in Win32Utils.c
1040 foreign import stdcall "WaitForSingleObject"
1041 c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD
1044 -- ----------------------------------------------------------------------------
1045 -- Unix IO manager thread, using select()
1047 startIOManagerThread :: IO ()
1048 startIOManagerThread = do
1049 allocaArray 2 $ \fds -> do
1050 throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)
1051 rd_end <- peekElemOff fds 0
1052 wr_end <- peekElemOff fds 1
1053 setNonBlockingFD wr_end -- writes happen in a signal handler, we
1054 -- don't want them to block.
1055 writeIORef stick (fromIntegral wr_end)
1056 c_setIOManagerPipe wr_end
1058 allocaBytes sizeofFdSet $ \readfds -> do
1059 allocaBytes sizeofFdSet $ \writefds -> do
1060 allocaBytes sizeofTimeVal $ \timeval -> do
1061 service_loop (fromIntegral rd_end) readfds writefds timeval [] []
1065 :: Fd -- listen to this for wakeup calls
1072 service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
1074 -- pick up new IO requests
1075 new_reqs <- atomicModifyIORef pendingEvents (\a -> ([],a))
1076 let reqs = new_reqs ++ old_reqs
1078 -- pick up new delay requests
1079 new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
1080 let delays0 = foldr insertDelay old_delays new_delays
1082 -- build the FDSets for select()
1085 fdSet wakeup readfds
1086 maxfd <- buildFdSets 0 readfds writefds reqs
1088 -- perform the select()
1089 let do_select delays = do
1090 -- check the current time and wake up any thread in
1091 -- threadDelay whose timeout has expired. Also find the
1092 -- timeout value for the select() call.
1094 (delays', timeout) <- getDelay now ptimeval delays
1096 res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds
1102 _ | err == eINTR -> do_select delays'
1103 -- EINTR: just redo the select()
1104 _ | err == eBADF -> return (True, delays)
1105 -- EBADF: one of the file descriptors is closed or bad,
1106 -- we don't know which one, so wake everyone up.
1107 _ | otherwise -> throwErrno "select"
1108 -- otherwise (ENOMEM or EINVAL) something has gone
1109 -- wrong; report the error.
1111 return (False,delays')
1113 (wakeup_all,delays') <- do_select delays0
1116 if wakeup_all then return False
1118 b <- fdIsSet wakeup readfds
1121 else alloca $ \p -> do
1122 c_read (fromIntegral wakeup) p 1
1125 _ | s == io_MANAGER_WAKEUP -> return False
1126 _ | s == io_MANAGER_DIE -> return True
1127 _ | s == io_MANAGER_SYNC -> do
1128 mvars <- readIORef sync
1129 mapM_ (flip putMVar ()) mvars
1132 fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
1133 withForeignPtr fp $ \p_siginfo -> do
1134 r <- c_read (fromIntegral wakeup) (castPtr p_siginfo)
1136 when (r /= fromIntegral sizeof_siginfo_t) $
1137 error "failed to read siginfo_t"
1138 runHandlers' fp (fromIntegral s)
1141 if exit then return () else do
1143 atomicModifyIORef prodding (\_ -> (False,False))
1145 reqs' <- if wakeup_all then do wakeupAll reqs; return []
1146 else completeRequests reqs readfds writefds []
1148 service_loop wakeup readfds writefds ptimeval reqs' delays'
1150 io_MANAGER_WAKEUP, io_MANAGER_DIE, io_MANAGER_SYNC :: CChar
1151 io_MANAGER_WAKEUP = 0xff
1152 io_MANAGER_DIE = 0xfe
1153 io_MANAGER_SYNC = 0xfd
1155 -- | the stick is for poking the IO manager with
1157 {-# NOINLINE stick #-}
1158 stick = unsafePerformIO (newIORef 0)
1160 {-# NOINLINE sync #-}
1161 sync :: IORef [MVar ()]
1162 sync = unsafePerformIO (newIORef [])
1164 -- waits for the IO manager to drain the pipe
1165 syncIOManager :: IO ()
1168 atomicModifyIORef sync (\old -> (m:old,()))
1169 fd <- readIORef stick
1170 with io_MANAGER_SYNC $ \pbuf -> do
1171 c_write (fromIntegral fd) pbuf 1; return ()
1174 wakeupIOManager :: IO ()
1175 wakeupIOManager = do
1176 fd <- readIORef stick
1177 with io_MANAGER_WAKEUP $ \pbuf -> do
1178 c_write (fromIntegral fd) pbuf 1; return ()
1180 -- For the non-threaded RTS
1181 runHandlers :: Ptr Word8 -> Int -> IO ()
1182 runHandlers p_info sig = do
1183 fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
1184 withForeignPtr fp $ \p -> do
1185 copyBytes p p_info (fromIntegral sizeof_siginfo_t)
1187 runHandlers' fp (fromIntegral sig)
1189 runHandlers' :: ForeignPtr Word8 -> Signal -> IO ()
1190 runHandlers' p_info sig = do
1191 let int = fromIntegral sig
1192 withMVar signal_handlers $ \arr ->
1193 if not (inRange (boundsIOArray arr) int)
1195 else do handler <- unsafeReadIOArray arr int
1197 Nothing -> return ()
1198 Just (f,_) -> do forkIO (f p_info); return ()
1200 foreign import ccall "setIOManagerPipe"
1201 c_setIOManagerPipe :: CInt -> IO ()
1203 foreign import ccall "__hscore_sizeof_siginfo_t"
1204 sizeof_siginfo_t :: CSize
1210 type HandlerFun = ForeignPtr Word8 -> IO ()
1212 -- Lock used to protect concurrent access to signal_handlers. Symptom of
1213 -- this race condition is #1922, although that bug was on Windows a similar
1214 -- bug also exists on Unix.
1215 {-# NOINLINE signal_handlers #-}
1216 signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic)))
1217 signal_handlers = unsafePerformIO $ do
1218 arr <- newIOArray (0,maxSig) Nothing
1221 setHandler :: Signal -> Maybe (HandlerFun,Dynamic) -> IO (Maybe (HandlerFun,Dynamic))
1222 setHandler sig handler = do
1223 let int = fromIntegral sig
1224 withMVar signal_handlers $ \arr ->
1225 if not (inRange (boundsIOArray arr) int)
1226 then error "GHC.Conc.setHandler: signal out of range"
1227 else do old <- unsafeReadIOArray arr int
1228 unsafeWriteIOArray arr int handler
1231 -- -----------------------------------------------------------------------------
1234 buildFdSets :: Fd -> Ptr CFdSet -> Ptr CFdSet -> [IOReq] -> IO Fd
1235 buildFdSets maxfd _ _ [] = return maxfd
1236 buildFdSets maxfd readfds writefds (Read fd _ : reqs)
1237 | fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range"
1240 buildFdSets (max maxfd fd) readfds writefds reqs
1241 buildFdSets maxfd readfds writefds (Write fd _ : reqs)
1242 | fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range"
1245 buildFdSets (max maxfd fd) readfds writefds reqs
1247 completeRequests :: [IOReq] -> Ptr CFdSet -> Ptr CFdSet -> [IOReq]
1249 completeRequests [] _ _ reqs' = return reqs'
1250 completeRequests (Read fd m : reqs) readfds writefds reqs' = do
1251 b <- fdIsSet fd readfds
1253 then do putMVar m (); completeRequests reqs readfds writefds reqs'
1254 else completeRequests reqs readfds writefds (Read fd m : reqs')
1255 completeRequests (Write fd m : reqs) readfds writefds reqs' = do
1256 b <- fdIsSet fd writefds
1258 then do putMVar m (); completeRequests reqs readfds writefds reqs'
1259 else completeRequests reqs readfds writefds (Write fd m : reqs')
1261 wakeupAll :: [IOReq] -> IO ()
1262 wakeupAll [] = return ()
1263 wakeupAll (Read _ m : reqs) = do putMVar m (); wakeupAll reqs
1264 wakeupAll (Write _ m : reqs) = do putMVar m (); wakeupAll reqs
1266 waitForReadEvent :: Fd -> IO ()
1267 waitForReadEvent fd = do
1269 atomicModifyIORef pendingEvents (\xs -> (Read fd m : xs, ()))
1273 waitForWriteEvent :: Fd -> IO ()
1274 waitForWriteEvent fd = do
1276 atomicModifyIORef pendingEvents (\xs -> (Write fd m : xs, ()))
1280 -- -----------------------------------------------------------------------------
1283 -- Walk the queue of pending delays, waking up any that have passed
1284 -- and return the smallest delay to wait for. The queue of pending
1285 -- delays is kept ordered.
1286 getDelay :: USecs -> Ptr CTimeVal -> [DelayReq] -> IO ([DelayReq], Ptr CTimeVal)
1287 getDelay _ _ [] = return ([],nullPtr)
1288 getDelay now ptimeval all@(d : rest)
1290 Delay time m | now >= time -> do
1292 getDelay now ptimeval rest
1293 DelaySTM time t | now >= time -> do
1294 atomically $ writeTVar t True
1295 getDelay now ptimeval rest
1297 setTimevalTicks ptimeval (delayTime d - now)
1298 return (all,ptimeval)
1302 foreign import ccall unsafe "sizeofTimeVal"
1303 sizeofTimeVal :: Int
1305 foreign import ccall unsafe "setTimevalTicks"
1306 setTimevalTicks :: Ptr CTimeVal -> USecs -> IO ()
1309 On Win32 we're going to have a single Pipe, and a
1310 waitForSingleObject with the delay time. For signals, we send a
1311 byte down the pipe just like on Unix.
1314 -- ----------------------------------------------------------------------------
1315 -- select() interface
1317 -- ToDo: move to System.Posix.Internals?
1321 foreign import ccall safe "select"
1322 c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
1325 foreign import ccall unsafe "hsFD_SETSIZE"
1326 c_fD_SETSIZE :: CInt
1329 fD_SETSIZE = fromIntegral c_fD_SETSIZE
1331 foreign import ccall unsafe "hsFD_ISSET"
1332 c_fdIsSet :: CInt -> Ptr CFdSet -> IO CInt
1334 fdIsSet :: Fd -> Ptr CFdSet -> IO CInt
1335 fdIsSet (Fd fd) fdset = c_fdIsSet fd fdset
1337 foreign import ccall unsafe "hsFD_SET"
1338 c_fdSet :: CInt -> Ptr CFdSet -> IO ()
1340 fdSet :: Fd -> Ptr CFdSet -> IO ()
1341 fdSet (Fd fd) fdset = c_fdSet fd fdset
1343 foreign import ccall unsafe "hsFD_ZERO"
1344 fdZero :: Ptr CFdSet -> IO ()
1346 foreign import ccall unsafe "sizeof_fd_set"
1351 reportStackOverflow :: IO a
1352 reportStackOverflow = do callStackOverflowHook; return undefined
1354 reportError :: SomeException -> IO a
1356 handler <- getUncaughtExceptionHandler
1360 -- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove
1361 -- the unsafe below.
1362 foreign import ccall unsafe "stackOverflow"
1363 callStackOverflowHook :: IO ()
1365 {-# NOINLINE uncaughtExceptionHandler #-}
1366 uncaughtExceptionHandler :: IORef (SomeException -> IO ())
1367 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
1369 defaultHandler :: SomeException -> IO ()
1370 defaultHandler se@(SomeException ex) = do
1371 (hFlush stdout) `catchAny` (\ _ -> return ())
1372 let msg = case cast ex of
1373 Just Deadlock -> "no threads to run: infinite loop or deadlock?"
1374 _ -> case cast ex of
1375 Just (ErrorCall s) -> s
1376 _ -> showsPrec 0 se ""
1377 withCString "%s" $ \cfmt ->
1378 withCString msg $ \cmsg ->
1379 errorBelch cfmt cmsg
1381 -- don't use errorBelch() directly, because we cannot call varargs functions
1383 foreign import ccall unsafe "HsBase.h errorBelch2"
1384 errorBelch :: CString -> CString -> IO ()
1386 setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
1387 setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
1389 getUncaughtExceptionHandler :: IO (SomeException -> IO ())
1390 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
1393 withMVar :: MVar a -> (a -> IO b) -> IO b
1397 b <- catchAny (unblock (io a))
1398 (\e -> do putMVar m a; throw e)