2 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
3 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
4 {-# OPTIONS_HADDOCK not-home #-}
5 -----------------------------------------------------------------------------
7 -- Module : GHC.Conc.Sync
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
33 , forkOnIO -- :: Int -> IO a -> IO ThreadId
35 , numCapabilities -- :: Int
36 , numSparks -- :: IO Int
37 , childHandler -- :: Exception -> IO ()
38 , myThreadId -- :: IO ThreadId
39 , killThread -- :: ThreadId -> IO ()
40 , throwTo -- :: ThreadId -> Exception -> IO ()
41 , par -- :: a -> b -> b
42 , pseq -- :: a -> b -> b
45 , labelThread -- :: ThreadId -> String -> IO ()
47 , ThreadStatus(..), BlockReason(..)
48 , threadStatus -- :: ThreadId -> IO ThreadStatus
52 , atomically -- :: STM a -> IO a
54 , orElse -- :: STM a -> STM a -> STM a
55 , throwSTM -- :: Exception e => e -> STM a
56 , catchSTM -- :: Exception e => STM a -> (e -> STM a) -> STM a
57 , alwaysSucceeds -- :: STM a -> STM ()
58 , always -- :: STM Bool -> STM ()
60 , newTVar -- :: a -> STM (TVar a)
61 , newTVarIO -- :: a -> STM (TVar a)
62 , readTVar -- :: TVar a -> STM a
63 , readTVarIO -- :: TVar a -> IO a
64 , writeTVar -- :: a -> TVar a -> STM ()
65 , unsafeIOToSTM -- :: IO a -> STM a
71 , setUncaughtExceptionHandler -- :: (Exception -> IO ()) -> IO ()
72 , getUncaughtExceptionHandler -- :: IO (Exception -> IO ())
74 , reportError, reportStackOverflow
79 import Foreign hiding (unsafePerformIO)
82 #ifdef mingw32_HOST_OS
86 #ifndef mingw32_HOST_OS
93 import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
94 import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout )
96 import GHC.IO.Exception
100 import GHC.Num ( Num(..) )
101 import GHC.Real ( fromIntegral )
102 import GHC.Pack ( packCString# )
103 import GHC.Show ( Show(..), showString )
105 infixr 0 `par`, `pseq`
108 %************************************************************************
110 \subsection{@ThreadId@, @par@, and @fork@}
112 %************************************************************************
115 data ThreadId = ThreadId ThreadId# deriving( Typeable )
116 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
117 -- But since ThreadId# is unlifted, the Weak type must use open
120 A 'ThreadId' is an abstract type representing a handle to a thread.
121 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
122 the 'Ord' instance implements an arbitrary total ordering over
123 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
124 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
125 useful when debugging or diagnosing the behaviour of a concurrent
128 /Note/: in GHC, if you have a 'ThreadId', you essentially have
129 a pointer to the thread itself. This means the thread itself can\'t be
130 garbage collected until you drop the 'ThreadId'.
131 This misfeature will hopefully be corrected at a later date.
133 /Note/: Hugs does not provide any operations on other threads;
134 it defines 'ThreadId' as a synonym for ().
137 instance Show ThreadId where
139 showString "ThreadId " .
140 showsPrec d (getThreadId (id2TSO t))
142 foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
144 id2TSO :: ThreadId -> ThreadId#
145 id2TSO (ThreadId t) = t
147 foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
150 cmpThread :: ThreadId -> ThreadId -> Ordering
152 case cmp_thread (id2TSO t1) (id2TSO t2) of
157 instance Eq ThreadId where
159 case t1 `cmpThread` t2 of
163 instance Ord ThreadId where
167 Sparks off a new thread to run the 'IO' computation passed as the
168 first argument, and returns the 'ThreadId' of the newly created
171 The new thread will be a lightweight thread; if you want to use a foreign
172 library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead.
174 GHC note: the new thread inherits the /masked/ state of the parent
175 (see 'Control.Exception.mask').
177 The newly created thread has an exception handler that discards the
178 exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and
179 'ThreadKilled', and passes all other exceptions to the uncaught
180 exception handler (see 'setUncaughtExceptionHandler').
182 forkIO :: IO () -> IO ThreadId
183 forkIO action = IO $ \ s ->
184 case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
186 action_plus = catchException action childHandler
188 -- | Like 'forkIO', but the child thread is created with asynchronous exceptions
189 -- unmasked (see 'Control.Exception.mask').
190 forkIOUnmasked :: IO () -> IO ThreadId
191 forkIOUnmasked io = forkIO (unsafeUnmask io)
194 Like 'forkIO', but lets you specify on which CPU the thread is
195 created. Unlike a `forkIO` thread, a thread created by `forkOnIO`
196 will stay on the same CPU for its entire lifetime (`forkIO` threads
197 can migrate between CPUs according to the scheduling policy).
198 `forkOnIO` is useful for overriding the scheduling policy when you
199 know in advance how best to distribute the threads.
201 The `Int` argument specifies the CPU number; it is interpreted modulo
202 'numCapabilities' (note that it actually specifies a capability number
203 rather than a CPU number, but to a first approximation the two are
206 forkOnIO :: Int -> IO () -> IO ThreadId
207 forkOnIO (I# cpu) action = IO $ \ s ->
208 case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
210 action_plus = catchException action childHandler
212 -- | Like 'forkOnIO', but the child thread is created with
213 -- asynchronous exceptions unmasked (see 'Control.Exception.mask').
214 forkOnIOUnmasked :: Int -> IO () -> IO ThreadId
215 forkOnIOUnmasked cpu io = forkOnIO cpu (unsafeUnmask io)
217 -- | the value passed to the @+RTS -N@ flag. This is the number of
218 -- Haskell threads that can run truly simultaneously at any given
219 -- time, and is typically set to the number of physical CPU cores on
221 numCapabilities :: Int
222 numCapabilities = unsafePerformIO $ do
223 n <- peek n_capabilities
224 return (fromIntegral n)
226 -- | Returns the number of sparks currently in the local spark pool
228 numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #)
230 #if defined(mingw32_HOST_OS) && defined(__PIC__)
231 foreign import ccall "_imp__n_capabilities" n_capabilities :: Ptr CInt
233 foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt
235 childHandler :: SomeException -> IO ()
236 childHandler err = catchException (real_handler err) childHandler
238 real_handler :: SomeException -> IO ()
239 real_handler se@(SomeException ex) =
240 -- ignore thread GC and killThread exceptions:
242 Just BlockedIndefinitelyOnMVar -> return ()
244 Just BlockedIndefinitelyOnSTM -> return ()
246 Just ThreadKilled -> return ()
248 -- report all others:
249 Just StackOverflow -> reportStackOverflow
252 {- | 'killThread' raises the 'ThreadKilled' exception in the given
255 > killThread tid = throwTo tid ThreadKilled
258 killThread :: ThreadId -> IO ()
259 killThread tid = throwTo tid ThreadKilled
261 {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
263 'throwTo' does not return until the exception has been raised in the
265 The calling thread can thus be certain that the target
266 thread has received the exception. This is a useful property to know
267 when dealing with race conditions: eg. if there are two threads that
268 can kill each other, it is guaranteed that only one of the threads
269 will get to kill the other.
271 Whatever work the target thread was doing when the exception was
272 raised is not lost: the computation is suspended until required by
275 If the target thread is currently making a foreign call, then the
276 exception will not be raised (and hence 'throwTo' will not return)
277 until the call has completed. This is the case regardless of whether
278 the call is inside a 'mask' or not. However, in GHC a foreign call
279 can be annotated as @interruptible@, in which case a 'throwTo' will
280 cause the RTS to attempt to cause the call to return; see the GHC
281 documentation for more details.
283 Important note: the behaviour of 'throwTo' differs from that described in
284 the paper \"Asynchronous exceptions in Haskell\"
285 (<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>).
286 In the paper, 'throwTo' is non-blocking; but the library implementation adopts
287 a more synchronous design in which 'throwTo' does not return until the exception
288 is received by the target thread. The trade-off is discussed in Section 9 of the paper.
289 Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of
290 the paper). Unlike other interruptible operations, however, 'throwTo'
291 is /always/ interruptible, even if it does not actually block.
293 There is no guarantee that the exception will be delivered promptly,
294 although the runtime will endeavour to ensure that arbitrary
295 delays don't occur. In GHC, an exception can only be raised when a
296 thread reaches a /safe point/, where a safe point is where memory
297 allocation occurs. Some loops do not perform any memory allocation
298 inside the loop and therefore cannot be interrupted by a 'throwTo'.
300 Blocked 'throwTo' is fair: if multiple threads are trying to throw an
301 exception to the same target thread, they will succeed in FIFO order.
304 throwTo :: Exception e => ThreadId -> e -> IO ()
305 throwTo (ThreadId tid) ex = IO $ \ s ->
306 case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)
308 -- | Returns the 'ThreadId' of the calling thread (GHC only).
309 myThreadId :: IO ThreadId
310 myThreadId = IO $ \s ->
311 case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)
314 -- |The 'yield' action allows (forces, in a co-operative multitasking
315 -- implementation) a context-switch to any other currently runnable
316 -- threads (if any), and is occasionally useful when implementing
317 -- concurrency abstractions.
320 case (yield# s) of s1 -> (# s1, () #)
322 {- | 'labelThread' stores a string as identifier for this thread if
323 you built a RTS with debugging support. This identifier will be used in
324 the debugging output to make distinction of different threads easier
325 (otherwise you only have the thread state object\'s address in the heap).
327 Other applications like the graphical Concurrent Haskell Debugger
328 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
329 'labelThread' for their purposes as well.
332 labelThread :: ThreadId -> String -> IO ()
333 labelThread (ThreadId t) str = IO $ \ s ->
334 let !ps = packCString# str
335 !adr = byteArrayContents# ps in
336 case (labelThread# t adr s) of s1 -> (# s1, () #)
338 -- Nota Bene: 'pseq' used to be 'seq'
339 -- but 'seq' is now defined in PrelGHC
341 -- "pseq" is defined a bit weirdly (see below)
343 -- The reason for the strange "lazy" call is that
344 -- it fools the compiler into thinking that pseq and par are non-strict in
345 -- their second argument (even if it inlines pseq at the call site).
346 -- If it thinks pseq is strict in "y", then it often evaluates
347 -- "y" before "x", which is totally wrong.
351 pseq x y = x `seq` lazy y
355 par x y = case (par# x) of { _ -> lazy y }
357 -- | Internal function used by the RTS to run sparks.
360 where loop s = case getSpark# s of
362 if n ==# 0# then (# s', () #)
367 -- ^blocked on on 'MVar'
369 -- ^blocked on a computation in progress by another thread
371 -- ^blocked in 'throwTo'
373 -- ^blocked in 'retry' in an STM transaction
374 | BlockedOnForeignCall
375 -- ^currently in a foreign call
377 -- ^blocked on some other resource. Without @-threaded@,
378 -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
379 -- they show up as 'BlockedOnMVar'.
380 deriving (Eq,Ord,Show)
382 -- | The current status of a thread
385 -- ^the thread is currently runnable or running
387 -- ^the thread has finished
388 | ThreadBlocked BlockReason
389 -- ^the thread is blocked on some resource
391 -- ^the thread received an uncaught exception
392 deriving (Eq,Ord,Show)
394 threadStatus :: ThreadId -> IO ThreadStatus
395 threadStatus (ThreadId t) = IO $ \s ->
396 case threadStatus# t s of
397 (# s', stat #) -> (# s', mk_stat (I# stat) #)
399 -- NB. keep these in sync with includes/Constants.h
400 mk_stat 0 = ThreadRunning
401 mk_stat 1 = ThreadBlocked BlockedOnMVar
402 mk_stat 2 = ThreadBlocked BlockedOnBlackHole
403 mk_stat 3 = ThreadBlocked BlockedOnException
404 mk_stat 7 = ThreadBlocked BlockedOnSTM
405 mk_stat 11 = ThreadBlocked BlockedOnForeignCall
406 mk_stat 12 = ThreadBlocked BlockedOnForeignCall
407 mk_stat 16 = ThreadFinished
408 mk_stat 17 = ThreadDied
409 mk_stat _ = ThreadBlocked BlockedOnOther
413 %************************************************************************
415 \subsection[stm]{Transactional heap operations}
417 %************************************************************************
419 TVars are shared memory locations which support atomic memory
423 -- |A monad supporting atomic memory transactions.
424 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
426 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
429 INSTANCE_TYPEABLE1(STM,stmTc,"STM")
431 instance Functor STM where
432 fmap f x = x >>= (return . f)
434 instance Monad STM where
435 {-# INLINE return #-}
439 return x = returnSTM x
440 m >>= k = bindSTM m k
442 bindSTM :: STM a -> (a -> STM b) -> STM b
443 bindSTM (STM m) k = STM ( \s ->
445 (# new_s, a #) -> unSTM (k a) new_s
448 thenSTM :: STM a -> STM b -> STM b
449 thenSTM (STM m) k = STM ( \s ->
451 (# new_s, _ #) -> unSTM k new_s
454 returnSTM :: a -> STM a
455 returnSTM x = STM (\s -> (# s, x #))
457 instance MonadPlus STM where
461 -- | Unsafely performs IO in the STM monad. Beware: this is a highly
462 -- dangerous thing to do.
464 -- * The STM implementation will often run transactions multiple
465 -- times, so you need to be prepared for this if your IO has any
468 -- * The STM implementation will abort transactions that are known to
469 -- be invalid and need to be restarted. This may happen in the middle
470 -- of `unsafeIOToSTM`, so make sure you don't acquire any resources
471 -- that need releasing (exception handlers are ignored when aborting
472 -- the transaction). That includes doing any IO using Handles, for
473 -- example. Getting this wrong will probably lead to random deadlocks.
475 -- * The transaction may have seen an inconsistent view of memory when
476 -- the IO runs. Invariants that you expect to be true throughout
477 -- your program may not be true inside a transaction, due to the
478 -- way transactions are implemented. Normally this wouldn't be visible
479 -- to the programmer, but using `unsafeIOToSTM` can expose it.
481 unsafeIOToSTM :: IO a -> STM a
482 unsafeIOToSTM (IO m) = STM m
484 -- |Perform a series of STM actions atomically.
486 -- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.
487 -- Any attempt to do so will result in a runtime error. (Reason: allowing
488 -- this would effectively allow a transaction inside a transaction, depending
489 -- on exactly when the thunk is evaluated.)
491 -- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',
492 -- and which allows top-level TVars to be allocated.
494 atomically :: STM a -> IO a
495 atomically (STM m) = IO (\s -> (atomically# m) s )
497 -- |Retry execution of the current memory transaction because it has seen
498 -- values in TVars which mean that it should not continue (e.g. the TVars
499 -- represent a shared buffer that is now empty). The implementation may
500 -- block the thread until one of the TVars that it has read from has been
501 -- udpated. (GHC only)
503 retry = STM $ \s# -> retry# s#
505 -- |Compose two alternative STM actions (GHC only). If the first action
506 -- completes without retrying then it forms the result of the orElse.
507 -- Otherwise, if the first action retries, then the second action is
508 -- tried in its place. If both actions retry then the orElse as a
510 orElse :: STM a -> STM a -> STM a
511 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
513 -- | A variant of 'throw' that can only be used within the 'STM' monad.
515 -- Throwing an exception in @STM@ aborts the transaction and propagates the
518 -- Although 'throwSTM' has a type that is an instance of the type of 'throw', the
519 -- two functions are subtly different:
521 -- > throw e `seq` x ===> throw e
522 -- > throwSTM e `seq` x ===> x
524 -- The first example will cause the exception @e@ to be raised,
525 -- whereas the second one won\'t. In fact, 'throwSTM' will only cause
526 -- an exception to be raised when it is used within the 'STM' monad.
527 -- The 'throwSTM' variant should be used in preference to 'throw' to
528 -- raise an exception within the 'STM' monad because it guarantees
529 -- ordering with respect to other 'STM' operations, whereas 'throw'
531 throwSTM :: Exception e => e -> STM a
532 throwSTM e = STM $ raiseIO# (toException e)
534 -- |Exception handling within STM actions.
535 catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
536 catchSTM (STM m) handler = STM $ catchSTM# m handler'
538 handler' e = case fromException e of
539 Just e' -> unSTM (handler e')
540 Nothing -> raiseIO# e
542 -- | Low-level primitive on which always and alwaysSucceeds are built.
543 -- checkInv differs form these in that (i) the invariant is not
544 -- checked when checkInv is called, only at the end of this and
545 -- subsequent transcations, (ii) the invariant failure is indicated
546 -- by raising an exception.
547 checkInv :: STM a -> STM ()
548 checkInv (STM m) = STM (\s -> (check# m) s)
550 -- | alwaysSucceeds adds a new invariant that must be true when passed
551 -- to alwaysSucceeds, at the end of the current transaction, and at
552 -- the end of every subsequent transaction. If it fails at any
553 -- of those points then the transaction violating it is aborted
554 -- and the exception raised by the invariant is propagated.
555 alwaysSucceeds :: STM a -> STM ()
556 alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () )
559 -- | always is a variant of alwaysSucceeds in which the invariant is
560 -- expressed as an STM Bool action that must return True. Returning
561 -- False or raising an exception are both treated as invariant failures.
562 always :: STM Bool -> STM ()
563 always i = alwaysSucceeds ( do v <- i
564 if (v) then return () else ( error "Transacional invariant violation" ) )
566 -- |Shared memory locations that support atomic memory transactions.
567 data TVar a = TVar (TVar# RealWorld a)
569 INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")
571 instance Eq (TVar a) where
572 (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
574 -- |Create a new TVar holding a value supplied
575 newTVar :: a -> STM (TVar a)
576 newTVar val = STM $ \s1# ->
577 case newTVar# val s1# of
578 (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
580 -- |@IO@ version of 'newTVar'. This is useful for creating top-level
581 -- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
582 -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
584 newTVarIO :: a -> IO (TVar a)
585 newTVarIO val = IO $ \s1# ->
586 case newTVar# val s1# of
587 (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
589 -- |Return the current value stored in a TVar.
590 -- This is equivalent to
592 -- > readTVarIO = atomically . readTVar
594 -- but works much faster, because it doesn't perform a complete
595 -- transaction, it just reads the current value of the 'TVar'.
596 readTVarIO :: TVar a -> IO a
597 readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s#
599 -- |Return the current value stored in a TVar
600 readTVar :: TVar a -> STM a
601 readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
603 -- |Write the supplied value into a TVar
604 writeTVar :: TVar a -> a -> STM ()
605 writeTVar (TVar tvar#) val = STM $ \s1# ->
606 case writeTVar# tvar# val s1# of
614 withMVar :: MVar a -> (a -> IO b) -> IO b
616 mask $ \restore -> do
618 b <- catchAny (restore (io a))
619 (\e -> do putMVar m a; throw e)
623 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
625 mask $ \restore -> do
627 a' <- catchAny (restore (io a))
628 (\e -> do putMVar m a; throw e)
633 %************************************************************************
635 \subsection{Thread waiting}
637 %************************************************************************
641 -- Machinery needed to ensureb that we only have one copy of certain
642 -- CAFs in this module even when the base package is present twice, as
643 -- it is when base is dynamically loaded into GHCi. The RTS keeps
644 -- track of the single true value of the CAF, so even when the CAFs in
645 -- the dynamically-loaded base package are reverted, nothing bad
648 sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
649 sharedCAF a get_or_set =
651 stable_ref <- newStablePtr a
652 let ref = castPtr (castStablePtrToPtr stable_ref)
653 ref2 <- get_or_set ref
656 else do freeStablePtr stable_ref
657 deRefStablePtr (castPtrToStablePtr (castPtr ref2))
659 reportStackOverflow :: IO ()
660 reportStackOverflow = callStackOverflowHook
662 reportError :: SomeException -> IO ()
664 handler <- getUncaughtExceptionHandler
667 -- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove
669 foreign import ccall unsafe "stackOverflow"
670 callStackOverflowHook :: IO ()
672 {-# NOINLINE uncaughtExceptionHandler #-}
673 uncaughtExceptionHandler :: IORef (SomeException -> IO ())
674 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
676 defaultHandler :: SomeException -> IO ()
677 defaultHandler se@(SomeException ex) = do
678 (hFlush stdout) `catchAny` (\ _ -> return ())
679 let msg = case cast ex of
680 Just Deadlock -> "no threads to run: infinite loop or deadlock?"
682 Just (ErrorCall s) -> s
683 _ -> showsPrec 0 se ""
684 withCString "%s" $ \cfmt ->
685 withCString msg $ \cmsg ->
688 -- don't use errorBelch() directly, because we cannot call varargs functions
690 foreign import ccall unsafe "HsBase.h errorBelch2"
691 errorBelch :: CString -> CString -> IO ()
693 setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
694 setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
696 getUncaughtExceptionHandler :: IO (SomeException -> IO ())
697 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler