8 , ForeignFunctionInterface
12 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
13 {-# OPTIONS_HADDOCK not-home #-}
15 -----------------------------------------------------------------------------
17 -- Module : GHC.Conc.Sync
18 -- Copyright : (c) The University of Glasgow, 1994-2002
19 -- License : see libraries/base/LICENSE
21 -- Maintainer : cvs-ghc@haskell.org
22 -- Stability : internal
23 -- Portability : non-portable (GHC extensions)
25 -- Basic concurrency stuff.
27 -----------------------------------------------------------------------------
29 -- No: #hide, because bits of this module are exposed by the stm package.
30 -- However, we don't want this module to be the home location for the
31 -- bits it exports, we'd rather have Control.Concurrent and the other
32 -- higher level modules be the home. Hence:
40 -- * Forking and suchlike
41 , forkIO -- :: IO a -> IO ThreadId
44 , forkOn -- :: Int -> IO a -> IO ThreadId
45 , forkOnIO -- DEPRECATED
48 , numCapabilities -- :: Int
49 , getNumCapabilities -- :: IO Int
50 , numSparks -- :: IO Int
51 , childHandler -- :: Exception -> IO ()
52 , myThreadId -- :: IO ThreadId
53 , killThread -- :: ThreadId -> IO ()
54 , throwTo -- :: ThreadId -> Exception -> IO ()
55 , par -- :: a -> b -> b
56 , pseq -- :: a -> b -> b
59 , labelThread -- :: ThreadId -> String -> IO ()
61 , ThreadStatus(..), BlockReason(..)
62 , threadStatus -- :: ThreadId -> IO ThreadStatus
67 , atomically -- :: STM a -> IO a
69 , orElse -- :: STM a -> STM a -> STM a
70 , throwSTM -- :: Exception e => e -> STM a
71 , catchSTM -- :: Exception e => STM a -> (e -> STM a) -> STM a
72 , alwaysSucceeds -- :: STM a -> STM ()
73 , always -- :: STM Bool -> STM ()
75 , newTVar -- :: a -> STM (TVar a)
76 , newTVarIO -- :: a -> STM (TVar a)
77 , readTVar -- :: TVar a -> STM a
78 , readTVarIO -- :: TVar a -> IO a
79 , writeTVar -- :: a -> TVar a -> STM ()
80 , unsafeIOToSTM -- :: IO a -> STM a
86 , setUncaughtExceptionHandler -- :: (Exception -> IO ()) -> IO ()
87 , getUncaughtExceptionHandler -- :: IO (Exception -> IO ())
89 , reportError, reportStackOverflow
94 import Foreign hiding (unsafePerformIO)
97 #ifdef mingw32_HOST_OS
101 #ifndef mingw32_HOST_OS
108 import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
109 import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout )
111 import GHC.IO.Exception
115 import GHC.Real ( fromIntegral )
116 import GHC.Pack ( packCString# )
117 import GHC.Show ( Show(..), showString )
119 infixr 0 `par`, `pseq`
122 %************************************************************************
124 \subsection{@ThreadId@, @par@, and @fork@}
126 %************************************************************************
129 data ThreadId = ThreadId ThreadId# deriving( Typeable )
130 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
131 -- But since ThreadId# is unlifted, the Weak type must use open
134 A 'ThreadId' is an abstract type representing a handle to a thread.
135 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
136 the 'Ord' instance implements an arbitrary total ordering over
137 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
138 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
139 useful when debugging or diagnosing the behaviour of a concurrent
142 /Note/: in GHC, if you have a 'ThreadId', you essentially have
143 a pointer to the thread itself. This means the thread itself can\'t be
144 garbage collected until you drop the 'ThreadId'.
145 This misfeature will hopefully be corrected at a later date.
147 /Note/: Hugs does not provide any operations on other threads;
148 it defines 'ThreadId' as a synonym for ().
151 instance Show ThreadId where
153 showString "ThreadId " .
154 showsPrec d (getThreadId (id2TSO t))
156 foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
158 id2TSO :: ThreadId -> ThreadId#
159 id2TSO (ThreadId t) = t
161 foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
164 cmpThread :: ThreadId -> ThreadId -> Ordering
166 case cmp_thread (id2TSO t1) (id2TSO t2) of
171 instance Eq ThreadId where
173 case t1 `cmpThread` t2 of
177 instance Ord ThreadId where
181 Sparks off a new thread to run the 'IO' computation passed as the
182 first argument, and returns the 'ThreadId' of the newly created
185 The new thread will be a lightweight thread; if you want to use a foreign
186 library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead.
188 GHC note: the new thread inherits the /masked/ state of the parent
189 (see 'Control.Exception.mask').
191 The newly created thread has an exception handler that discards the
192 exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and
193 'ThreadKilled', and passes all other exceptions to the uncaught
194 exception handler (see 'setUncaughtExceptionHandler').
196 forkIO :: IO () -> IO ThreadId
197 forkIO action = IO $ \ s ->
198 case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
200 action_plus = catchException action childHandler
202 {-# DEPRECATED forkIOUnmasked "use forkIOWithUnmask instead" #-}
203 -- | This function is deprecated; use 'forkIOWIthUnmask' instead
204 forkIOUnmasked :: IO () -> IO ThreadId
205 forkIOUnmasked io = forkIO (unsafeUnmask io)
207 -- | Like 'forkIO', but the child thread is passed a function that can
208 -- be used to unmask asynchronous exceptions. This function is
209 -- typically used in the following way
211 -- > ... mask_ $ forkIOWithUnmask $ \unmask ->
212 -- > catch (unmask ...) handler
214 -- so that the exception handler in the child thread is established
215 -- with asynchronous exceptions masked, meanwhile the main body of
216 -- the child thread is executed in the unmasked state.
218 -- Note that the unmask function passed to the child thread should
219 -- only be used in that thread; the behaviour is undefined if it is
220 -- invoked in a different thread.
222 forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
223 forkIOWithUnmask io = forkIO (io unsafeUnmask)
226 Like 'forkIO', but lets you specify on which processor the thread
227 should run. Unlike a `forkIO` thread, a thread created by `forkOn`
228 will stay on the same processor for its entire lifetime (`forkIO`
229 threads can migrate between processors according to the scheduling
230 policy). `forkOn` is useful for overriding the scheduling policy when
231 you know in advance how best to distribute the threads.
233 The `Int` argument specifies a /capability number/ (see
234 'getNumCapabilities'). Typically capabilities correspond to physical
235 processors, but the exact behaviour is implementation-dependent. The
236 value passed to 'forkOn' is interpreted modulo the total number of
237 capabilities as returned by 'getNumCapabilities'.
239 GHC note: the number of capabilities is specified by the @+RTS -N@
240 option when the program is started. Capabilities can be fixed to
241 actual processor cores with @+RTS -qa@ if the underlying operating
242 system supports that, although in practice this is usually unnecessary
243 (and may actually degrade perforamnce in some cases - experimentation
246 forkOn :: Int -> IO () -> IO ThreadId
247 forkOn (I# cpu) action = IO $ \ s ->
248 case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
250 action_plus = catchException action childHandler
252 {-# DEPRECATED forkOnIO "renamed to forkOn" #-}
253 -- | This function is deprecated; use 'forkOn' instead
254 forkOnIO :: Int -> IO () -> IO ThreadId
257 {-# DEPRECATED forkOnIOUnmasked "use forkOnWithUnmask instead" #-}
258 -- | This function is deprecated; use 'forkOnWIthUnmask' instead
259 forkOnIOUnmasked :: Int -> IO () -> IO ThreadId
260 forkOnIOUnmasked cpu io = forkOn cpu (unsafeUnmask io)
262 -- | Like 'forkIOWithUnmask', but the child thread is pinned to the
263 -- given CPU, as with 'forkOn'.
264 forkOnWithUnmask :: Int -> ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
265 forkOnWithUnmask cpu io = forkOn cpu (io unsafeUnmask)
267 -- | the value passed to the @+RTS -N@ flag. This is the number of
268 -- Haskell threads that can run truly simultaneously at any given
269 -- time, and is typically set to the number of physical processor cores on
272 -- Strictly speaking it is better to use 'getNumCapabilities', because
273 -- the number of capabilities might vary at runtime.
275 numCapabilities :: Int
276 numCapabilities = unsafePerformIO $ getNumCapabilities
279 Returns the number of Haskell threads that can run truly
280 simultaneously (on separate physical processors) at any given time.
281 The number passed to `forkOn` is interpreted modulo this
284 An implementation in which Haskell threads are mapped directly to
285 OS threads might return the number of physical processor cores in
286 the machine, and 'forkOn' would be implemented using the OS's
287 affinity facilities. An implementation that schedules Haskell
288 threads onto a smaller number of OS threads (like GHC) would return
289 the number of such OS threads that can be running simultaneously.
291 GHC notes: this returns the number passed as the argument to the
292 @+RTS -N@ flag. In current implementations, the value is fixed
293 when the program starts and never changes, but it is possible that
294 in the future the number of capabilities might vary at runtime.
296 getNumCapabilities :: IO Int
297 getNumCapabilities = do
298 n <- peek n_capabilities
299 return (fromIntegral n)
301 -- | Returns the number of sparks currently in the local spark pool
303 numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #)
305 #if defined(mingw32_HOST_OS) && defined(__PIC__)
306 foreign import ccall "_imp__n_capabilities" n_capabilities :: Ptr CInt
308 foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt
310 childHandler :: SomeException -> IO ()
311 childHandler err = catchException (real_handler err) childHandler
313 real_handler :: SomeException -> IO ()
314 real_handler se@(SomeException ex) =
315 -- ignore thread GC and killThread exceptions:
317 Just BlockedIndefinitelyOnMVar -> return ()
319 Just BlockedIndefinitelyOnSTM -> return ()
321 Just ThreadKilled -> return ()
323 -- report all others:
324 Just StackOverflow -> reportStackOverflow
327 {- | 'killThread' raises the 'ThreadKilled' exception in the given
330 > killThread tid = throwTo tid ThreadKilled
333 killThread :: ThreadId -> IO ()
334 killThread tid = throwTo tid ThreadKilled
336 {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
338 'throwTo' does not return until the exception has been raised in the
340 The calling thread can thus be certain that the target
341 thread has received the exception. This is a useful property to know
342 when dealing with race conditions: eg. if there are two threads that
343 can kill each other, it is guaranteed that only one of the threads
344 will get to kill the other.
346 Whatever work the target thread was doing when the exception was
347 raised is not lost: the computation is suspended until required by
350 If the target thread is currently making a foreign call, then the
351 exception will not be raised (and hence 'throwTo' will not return)
352 until the call has completed. This is the case regardless of whether
353 the call is inside a 'mask' or not. However, in GHC a foreign call
354 can be annotated as @interruptible@, in which case a 'throwTo' will
355 cause the RTS to attempt to cause the call to return; see the GHC
356 documentation for more details.
358 Important note: the behaviour of 'throwTo' differs from that described in
359 the paper \"Asynchronous exceptions in Haskell\"
360 (<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>).
361 In the paper, 'throwTo' is non-blocking; but the library implementation adopts
362 a more synchronous design in which 'throwTo' does not return until the exception
363 is received by the target thread. The trade-off is discussed in Section 9 of the paper.
364 Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of
365 the paper). Unlike other interruptible operations, however, 'throwTo'
366 is /always/ interruptible, even if it does not actually block.
368 There is no guarantee that the exception will be delivered promptly,
369 although the runtime will endeavour to ensure that arbitrary
370 delays don't occur. In GHC, an exception can only be raised when a
371 thread reaches a /safe point/, where a safe point is where memory
372 allocation occurs. Some loops do not perform any memory allocation
373 inside the loop and therefore cannot be interrupted by a 'throwTo'.
375 Blocked 'throwTo' is fair: if multiple threads are trying to throw an
376 exception to the same target thread, they will succeed in FIFO order.
379 throwTo :: Exception e => ThreadId -> e -> IO ()
380 throwTo (ThreadId tid) ex = IO $ \ s ->
381 case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)
383 -- | Returns the 'ThreadId' of the calling thread (GHC only).
384 myThreadId :: IO ThreadId
385 myThreadId = IO $ \s ->
386 case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)
389 -- |The 'yield' action allows (forces, in a co-operative multitasking
390 -- implementation) a context-switch to any other currently runnable
391 -- threads (if any), and is occasionally useful when implementing
392 -- concurrency abstractions.
395 case (yield# s) of s1 -> (# s1, () #)
397 {- | 'labelThread' stores a string as identifier for this thread if
398 you built a RTS with debugging support. This identifier will be used in
399 the debugging output to make distinction of different threads easier
400 (otherwise you only have the thread state object\'s address in the heap).
402 Other applications like the graphical Concurrent Haskell Debugger
403 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
404 'labelThread' for their purposes as well.
407 labelThread :: ThreadId -> String -> IO ()
408 labelThread (ThreadId t) str = IO $ \ s ->
409 let !ps = packCString# str
410 !adr = byteArrayContents# ps in
411 case (labelThread# t adr s) of s1 -> (# s1, () #)
413 -- Nota Bene: 'pseq' used to be 'seq'
414 -- but 'seq' is now defined in PrelGHC
416 -- "pseq" is defined a bit weirdly (see below)
418 -- The reason for the strange "lazy" call is that
419 -- it fools the compiler into thinking that pseq and par are non-strict in
420 -- their second argument (even if it inlines pseq at the call site).
421 -- If it thinks pseq is strict in "y", then it often evaluates
422 -- "y" before "x", which is totally wrong.
426 pseq x y = x `seq` lazy y
430 par x y = case (par# x) of { _ -> lazy y }
432 -- | Internal function used by the RTS to run sparks.
435 where loop s = case getSpark# s of
437 if n ==# 0# then (# s', () #)
442 -- ^blocked on on 'MVar'
444 -- ^blocked on a computation in progress by another thread
446 -- ^blocked in 'throwTo'
448 -- ^blocked in 'retry' in an STM transaction
449 | BlockedOnForeignCall
450 -- ^currently in a foreign call
452 -- ^blocked on some other resource. Without @-threaded@,
453 -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
454 -- they show up as 'BlockedOnMVar'.
455 deriving (Eq,Ord,Show)
457 -- | The current status of a thread
460 -- ^the thread is currently runnable or running
462 -- ^the thread has finished
463 | ThreadBlocked BlockReason
464 -- ^the thread is blocked on some resource
466 -- ^the thread received an uncaught exception
467 deriving (Eq,Ord,Show)
469 threadStatus :: ThreadId -> IO ThreadStatus
470 threadStatus (ThreadId t) = IO $ \s ->
471 case threadStatus# t s of
472 (# s', stat, _cap, _locked #) -> (# s', mk_stat (I# stat) #)
474 -- NB. keep these in sync with includes/Constants.h
475 mk_stat 0 = ThreadRunning
476 mk_stat 1 = ThreadBlocked BlockedOnMVar
477 mk_stat 2 = ThreadBlocked BlockedOnBlackHole
478 mk_stat 6 = ThreadBlocked BlockedOnSTM
479 mk_stat 10 = ThreadBlocked BlockedOnForeignCall
480 mk_stat 11 = ThreadBlocked BlockedOnForeignCall
481 mk_stat 12 = ThreadBlocked BlockedOnException
482 mk_stat 16 = ThreadFinished
483 mk_stat 17 = ThreadDied
484 mk_stat _ = ThreadBlocked BlockedOnOther
486 -- | returns the number of the capability on which the thread is currently
487 -- running, and a boolean indicating whether the thread is locked to
488 -- that capability or not. A thread is locked to a capability if it
489 -- was created with @forkOn@.
490 threadCapability :: ThreadId -> IO (Int, Bool)
491 threadCapability (ThreadId t) = IO $ \s ->
492 case threadStatus# t s of
493 (# s', _, cap#, locked# #) -> (# s', (I# cap#, locked# /=# 0#) #)
497 %************************************************************************
499 \subsection[stm]{Transactional heap operations}
501 %************************************************************************
503 TVars are shared memory locations which support atomic memory
507 -- |A monad supporting atomic memory transactions.
508 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
510 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
513 INSTANCE_TYPEABLE1(STM,stmTc,"STM")
515 instance Functor STM where
516 fmap f x = x >>= (return . f)
518 instance Monad STM where
519 {-# INLINE return #-}
523 return x = returnSTM x
524 m >>= k = bindSTM m k
526 bindSTM :: STM a -> (a -> STM b) -> STM b
527 bindSTM (STM m) k = STM ( \s ->
529 (# new_s, a #) -> unSTM (k a) new_s
532 thenSTM :: STM a -> STM b -> STM b
533 thenSTM (STM m) k = STM ( \s ->
535 (# new_s, _ #) -> unSTM k new_s
538 returnSTM :: a -> STM a
539 returnSTM x = STM (\s -> (# s, x #))
541 instance MonadPlus STM where
545 -- | Unsafely performs IO in the STM monad. Beware: this is a highly
546 -- dangerous thing to do.
548 -- * The STM implementation will often run transactions multiple
549 -- times, so you need to be prepared for this if your IO has any
552 -- * The STM implementation will abort transactions that are known to
553 -- be invalid and need to be restarted. This may happen in the middle
554 -- of `unsafeIOToSTM`, so make sure you don't acquire any resources
555 -- that need releasing (exception handlers are ignored when aborting
556 -- the transaction). That includes doing any IO using Handles, for
557 -- example. Getting this wrong will probably lead to random deadlocks.
559 -- * The transaction may have seen an inconsistent view of memory when
560 -- the IO runs. Invariants that you expect to be true throughout
561 -- your program may not be true inside a transaction, due to the
562 -- way transactions are implemented. Normally this wouldn't be visible
563 -- to the programmer, but using `unsafeIOToSTM` can expose it.
565 unsafeIOToSTM :: IO a -> STM a
566 unsafeIOToSTM (IO m) = STM m
568 -- |Perform a series of STM actions atomically.
570 -- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.
571 -- Any attempt to do so will result in a runtime error. (Reason: allowing
572 -- this would effectively allow a transaction inside a transaction, depending
573 -- on exactly when the thunk is evaluated.)
575 -- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',
576 -- and which allows top-level TVars to be allocated.
578 atomically :: STM a -> IO a
579 atomically (STM m) = IO (\s -> (atomically# m) s )
581 -- |Retry execution of the current memory transaction because it has seen
582 -- values in TVars which mean that it should not continue (e.g. the TVars
583 -- represent a shared buffer that is now empty). The implementation may
584 -- block the thread until one of the TVars that it has read from has been
585 -- udpated. (GHC only)
587 retry = STM $ \s# -> retry# s#
589 -- |Compose two alternative STM actions (GHC only). If the first action
590 -- completes without retrying then it forms the result of the orElse.
591 -- Otherwise, if the first action retries, then the second action is
592 -- tried in its place. If both actions retry then the orElse as a
594 orElse :: STM a -> STM a -> STM a
595 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
597 -- | A variant of 'throw' that can only be used within the 'STM' monad.
599 -- Throwing an exception in @STM@ aborts the transaction and propagates the
602 -- Although 'throwSTM' has a type that is an instance of the type of 'throw', the
603 -- two functions are subtly different:
605 -- > throw e `seq` x ===> throw e
606 -- > throwSTM e `seq` x ===> x
608 -- The first example will cause the exception @e@ to be raised,
609 -- whereas the second one won\'t. In fact, 'throwSTM' will only cause
610 -- an exception to be raised when it is used within the 'STM' monad.
611 -- The 'throwSTM' variant should be used in preference to 'throw' to
612 -- raise an exception within the 'STM' monad because it guarantees
613 -- ordering with respect to other 'STM' operations, whereas 'throw'
615 throwSTM :: Exception e => e -> STM a
616 throwSTM e = STM $ raiseIO# (toException e)
618 -- |Exception handling within STM actions.
619 catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
620 catchSTM (STM m) handler = STM $ catchSTM# m handler'
622 handler' e = case fromException e of
623 Just e' -> unSTM (handler e')
624 Nothing -> raiseIO# e
626 -- | Low-level primitive on which always and alwaysSucceeds are built.
627 -- checkInv differs form these in that (i) the invariant is not
628 -- checked when checkInv is called, only at the end of this and
629 -- subsequent transcations, (ii) the invariant failure is indicated
630 -- by raising an exception.
631 checkInv :: STM a -> STM ()
632 checkInv (STM m) = STM (\s -> (check# m) s)
634 -- | alwaysSucceeds adds a new invariant that must be true when passed
635 -- to alwaysSucceeds, at the end of the current transaction, and at
636 -- the end of every subsequent transaction. If it fails at any
637 -- of those points then the transaction violating it is aborted
638 -- and the exception raised by the invariant is propagated.
639 alwaysSucceeds :: STM a -> STM ()
640 alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () )
643 -- | always is a variant of alwaysSucceeds in which the invariant is
644 -- expressed as an STM Bool action that must return True. Returning
645 -- False or raising an exception are both treated as invariant failures.
646 always :: STM Bool -> STM ()
647 always i = alwaysSucceeds ( do v <- i
648 if (v) then return () else ( error "Transacional invariant violation" ) )
650 -- |Shared memory locations that support atomic memory transactions.
651 data TVar a = TVar (TVar# RealWorld a)
653 INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")
655 instance Eq (TVar a) where
656 (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
658 -- |Create a new TVar holding a value supplied
659 newTVar :: a -> STM (TVar a)
660 newTVar val = STM $ \s1# ->
661 case newTVar# val s1# of
662 (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
664 -- |@IO@ version of 'newTVar'. This is useful for creating top-level
665 -- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
666 -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
668 newTVarIO :: a -> IO (TVar a)
669 newTVarIO val = IO $ \s1# ->
670 case newTVar# val s1# of
671 (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
673 -- |Return the current value stored in a TVar.
674 -- This is equivalent to
676 -- > readTVarIO = atomically . readTVar
678 -- but works much faster, because it doesn't perform a complete
679 -- transaction, it just reads the current value of the 'TVar'.
680 readTVarIO :: TVar a -> IO a
681 readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s#
683 -- |Return the current value stored in a TVar
684 readTVar :: TVar a -> STM a
685 readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
687 -- |Write the supplied value into a TVar
688 writeTVar :: TVar a -> a -> STM ()
689 writeTVar (TVar tvar#) val = STM $ \s1# ->
690 case writeTVar# tvar# val s1# of
698 withMVar :: MVar a -> (a -> IO b) -> IO b
700 mask $ \restore -> do
702 b <- catchAny (restore (io a))
703 (\e -> do putMVar m a; throw e)
707 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
709 mask $ \restore -> do
711 a' <- catchAny (restore (io a))
712 (\e -> do putMVar m a; throw e)
717 %************************************************************************
719 \subsection{Thread waiting}
721 %************************************************************************
725 -- Machinery needed to ensureb that we only have one copy of certain
726 -- CAFs in this module even when the base package is present twice, as
727 -- it is when base is dynamically loaded into GHCi. The RTS keeps
728 -- track of the single true value of the CAF, so even when the CAFs in
729 -- the dynamically-loaded base package are reverted, nothing bad
732 sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
733 sharedCAF a get_or_set =
735 stable_ref <- newStablePtr a
736 let ref = castPtr (castStablePtrToPtr stable_ref)
737 ref2 <- get_or_set ref
740 else do freeStablePtr stable_ref
741 deRefStablePtr (castPtrToStablePtr (castPtr ref2))
743 reportStackOverflow :: IO ()
744 reportStackOverflow = callStackOverflowHook
746 reportError :: SomeException -> IO ()
748 handler <- getUncaughtExceptionHandler
751 -- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove
753 foreign import ccall unsafe "stackOverflow"
754 callStackOverflowHook :: IO ()
756 {-# NOINLINE uncaughtExceptionHandler #-}
757 uncaughtExceptionHandler :: IORef (SomeException -> IO ())
758 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
760 defaultHandler :: SomeException -> IO ()
761 defaultHandler se@(SomeException ex) = do
762 (hFlush stdout) `catchAny` (\ _ -> return ())
763 let msg = case cast ex of
764 Just Deadlock -> "no threads to run: infinite loop or deadlock?"
766 Just (ErrorCall s) -> s
767 _ -> showsPrec 0 se ""
768 withCString "%s" $ \cfmt ->
769 withCString msg $ \cmsg ->
772 -- don't use errorBelch() directly, because we cannot call varargs functions
774 foreign import ccall unsafe "HsBase.h errorBelch2"
775 errorBelch :: CString -> CString -> IO ()
777 setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
778 setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
780 getUncaughtExceptionHandler :: IO (SomeException -> IO ())
781 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler