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.Real ( fromIntegral )
101 import GHC.Pack ( packCString# )
102 import GHC.Show ( Show(..), showString )
104 infixr 0 `par`, `pseq`
107 %************************************************************************
109 \subsection{@ThreadId@, @par@, and @fork@}
111 %************************************************************************
114 data ThreadId = ThreadId ThreadId# deriving( Typeable )
115 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
116 -- But since ThreadId# is unlifted, the Weak type must use open
119 A 'ThreadId' is an abstract type representing a handle to a thread.
120 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
121 the 'Ord' instance implements an arbitrary total ordering over
122 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
123 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
124 useful when debugging or diagnosing the behaviour of a concurrent
127 /Note/: in GHC, if you have a 'ThreadId', you essentially have
128 a pointer to the thread itself. This means the thread itself can\'t be
129 garbage collected until you drop the 'ThreadId'.
130 This misfeature will hopefully be corrected at a later date.
132 /Note/: Hugs does not provide any operations on other threads;
133 it defines 'ThreadId' as a synonym for ().
136 instance Show ThreadId where
138 showString "ThreadId " .
139 showsPrec d (getThreadId (id2TSO t))
141 foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
143 id2TSO :: ThreadId -> ThreadId#
144 id2TSO (ThreadId t) = t
146 foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
149 cmpThread :: ThreadId -> ThreadId -> Ordering
151 case cmp_thread (id2TSO t1) (id2TSO t2) of
156 instance Eq ThreadId where
158 case t1 `cmpThread` t2 of
162 instance Ord ThreadId where
166 Sparks off a new thread to run the 'IO' computation passed as the
167 first argument, and returns the 'ThreadId' of the newly created
170 The new thread will be a lightweight thread; if you want to use a foreign
171 library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead.
173 GHC note: the new thread inherits the /masked/ state of the parent
174 (see 'Control.Exception.mask').
176 The newly created thread has an exception handler that discards the
177 exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and
178 'ThreadKilled', and passes all other exceptions to the uncaught
179 exception handler (see 'setUncaughtExceptionHandler').
181 forkIO :: IO () -> IO ThreadId
182 forkIO action = IO $ \ s ->
183 case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
185 action_plus = catchException action childHandler
187 -- | Like 'forkIO', but the child thread is created with asynchronous exceptions
188 -- unmasked (see 'Control.Exception.mask').
189 forkIOUnmasked :: IO () -> IO ThreadId
190 forkIOUnmasked io = forkIO (unsafeUnmask io)
193 Like 'forkIO', but lets you specify on which CPU the thread is
194 created. Unlike a `forkIO` thread, a thread created by `forkOnIO`
195 will stay on the same CPU for its entire lifetime (`forkIO` threads
196 can migrate between CPUs according to the scheduling policy).
197 `forkOnIO` is useful for overriding the scheduling policy when you
198 know in advance how best to distribute the threads.
200 The `Int` argument specifies the CPU number; it is interpreted modulo
201 'numCapabilities' (note that it actually specifies a capability number
202 rather than a CPU number, but to a first approximation the two are
205 forkOnIO :: Int -> IO () -> IO ThreadId
206 forkOnIO (I# cpu) action = IO $ \ s ->
207 case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
209 action_plus = catchException action childHandler
211 -- | Like 'forkOnIO', but the child thread is created with
212 -- asynchronous exceptions unmasked (see 'Control.Exception.mask').
213 forkOnIOUnmasked :: Int -> IO () -> IO ThreadId
214 forkOnIOUnmasked cpu io = forkOnIO cpu (unsafeUnmask io)
216 -- | the value passed to the @+RTS -N@ flag. This is the number of
217 -- Haskell threads that can run truly simultaneously at any given
218 -- time, and is typically set to the number of physical CPU cores on
220 numCapabilities :: Int
221 numCapabilities = unsafePerformIO $ do
222 n <- peek n_capabilities
223 return (fromIntegral n)
225 -- | Returns the number of sparks currently in the local spark pool
227 numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #)
229 #if defined(mingw32_HOST_OS) && defined(__PIC__)
230 foreign import ccall "_imp__n_capabilities" n_capabilities :: Ptr CInt
232 foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt
234 childHandler :: SomeException -> IO ()
235 childHandler err = catchException (real_handler err) childHandler
237 real_handler :: SomeException -> IO ()
238 real_handler se@(SomeException ex) =
239 -- ignore thread GC and killThread exceptions:
241 Just BlockedIndefinitelyOnMVar -> return ()
243 Just BlockedIndefinitelyOnSTM -> return ()
245 Just ThreadKilled -> return ()
247 -- report all others:
248 Just StackOverflow -> reportStackOverflow
251 {- | 'killThread' raises the 'ThreadKilled' exception in the given
254 > killThread tid = throwTo tid ThreadKilled
257 killThread :: ThreadId -> IO ()
258 killThread tid = throwTo tid ThreadKilled
260 {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
262 'throwTo' does not return until the exception has been raised in the
264 The calling thread can thus be certain that the target
265 thread has received the exception. This is a useful property to know
266 when dealing with race conditions: eg. if there are two threads that
267 can kill each other, it is guaranteed that only one of the threads
268 will get to kill the other.
270 Whatever work the target thread was doing when the exception was
271 raised is not lost: the computation is suspended until required by
274 If the target thread is currently making a foreign call, then the
275 exception will not be raised (and hence 'throwTo' will not return)
276 until the call has completed. This is the case regardless of whether
277 the call is inside a 'mask' or not. However, in GHC a foreign call
278 can be annotated as @interruptible@, in which case a 'throwTo' will
279 cause the RTS to attempt to cause the call to return; see the GHC
280 documentation for more details.
282 Important note: the behaviour of 'throwTo' differs from that described in
283 the paper \"Asynchronous exceptions in Haskell\"
284 (<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>).
285 In the paper, 'throwTo' is non-blocking; but the library implementation adopts
286 a more synchronous design in which 'throwTo' does not return until the exception
287 is received by the target thread. The trade-off is discussed in Section 9 of the paper.
288 Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of
289 the paper). Unlike other interruptible operations, however, 'throwTo'
290 is /always/ interruptible, even if it does not actually block.
292 There is no guarantee that the exception will be delivered promptly,
293 although the runtime will endeavour to ensure that arbitrary
294 delays don't occur. In GHC, an exception can only be raised when a
295 thread reaches a /safe point/, where a safe point is where memory
296 allocation occurs. Some loops do not perform any memory allocation
297 inside the loop and therefore cannot be interrupted by a 'throwTo'.
299 Blocked 'throwTo' is fair: if multiple threads are trying to throw an
300 exception to the same target thread, they will succeed in FIFO order.
303 throwTo :: Exception e => ThreadId -> e -> IO ()
304 throwTo (ThreadId tid) ex = IO $ \ s ->
305 case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)
307 -- | Returns the 'ThreadId' of the calling thread (GHC only).
308 myThreadId :: IO ThreadId
309 myThreadId = IO $ \s ->
310 case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)
313 -- |The 'yield' action allows (forces, in a co-operative multitasking
314 -- implementation) a context-switch to any other currently runnable
315 -- threads (if any), and is occasionally useful when implementing
316 -- concurrency abstractions.
319 case (yield# s) of s1 -> (# s1, () #)
321 {- | 'labelThread' stores a string as identifier for this thread if
322 you built a RTS with debugging support. This identifier will be used in
323 the debugging output to make distinction of different threads easier
324 (otherwise you only have the thread state object\'s address in the heap).
326 Other applications like the graphical Concurrent Haskell Debugger
327 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
328 'labelThread' for their purposes as well.
331 labelThread :: ThreadId -> String -> IO ()
332 labelThread (ThreadId t) str = IO $ \ s ->
333 let !ps = packCString# str
334 !adr = byteArrayContents# ps in
335 case (labelThread# t adr s) of s1 -> (# s1, () #)
337 -- Nota Bene: 'pseq' used to be 'seq'
338 -- but 'seq' is now defined in PrelGHC
340 -- "pseq" is defined a bit weirdly (see below)
342 -- The reason for the strange "lazy" call is that
343 -- it fools the compiler into thinking that pseq and par are non-strict in
344 -- their second argument (even if it inlines pseq at the call site).
345 -- If it thinks pseq is strict in "y", then it often evaluates
346 -- "y" before "x", which is totally wrong.
350 pseq x y = x `seq` lazy y
354 par x y = case (par# x) of { _ -> lazy y }
356 -- | Internal function used by the RTS to run sparks.
359 where loop s = case getSpark# s of
361 if n ==# 0# then (# s', () #)
366 -- ^blocked on on 'MVar'
368 -- ^blocked on a computation in progress by another thread
370 -- ^blocked in 'throwTo'
372 -- ^blocked in 'retry' in an STM transaction
373 | BlockedOnForeignCall
374 -- ^currently in a foreign call
376 -- ^blocked on some other resource. Without @-threaded@,
377 -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
378 -- they show up as 'BlockedOnMVar'.
379 deriving (Eq,Ord,Show)
381 -- | The current status of a thread
384 -- ^the thread is currently runnable or running
386 -- ^the thread has finished
387 | ThreadBlocked BlockReason
388 -- ^the thread is blocked on some resource
390 -- ^the thread received an uncaught exception
391 deriving (Eq,Ord,Show)
393 threadStatus :: ThreadId -> IO ThreadStatus
394 threadStatus (ThreadId t) = IO $ \s ->
395 case threadStatus# t s of
396 (# s', stat #) -> (# s', mk_stat (I# stat) #)
398 -- NB. keep these in sync with includes/Constants.h
399 mk_stat 0 = ThreadRunning
400 mk_stat 1 = ThreadBlocked BlockedOnMVar
401 mk_stat 2 = ThreadBlocked BlockedOnBlackHole
402 mk_stat 3 = ThreadBlocked BlockedOnException
403 mk_stat 7 = ThreadBlocked BlockedOnSTM
404 mk_stat 11 = ThreadBlocked BlockedOnForeignCall
405 mk_stat 12 = ThreadBlocked BlockedOnForeignCall
406 mk_stat 16 = ThreadFinished
407 mk_stat 17 = ThreadDied
408 mk_stat _ = ThreadBlocked BlockedOnOther
412 %************************************************************************
414 \subsection[stm]{Transactional heap operations}
416 %************************************************************************
418 TVars are shared memory locations which support atomic memory
422 -- |A monad supporting atomic memory transactions.
423 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
425 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
428 INSTANCE_TYPEABLE1(STM,stmTc,"STM")
430 instance Functor STM where
431 fmap f x = x >>= (return . f)
433 instance Monad STM where
434 {-# INLINE return #-}
438 return x = returnSTM x
439 m >>= k = bindSTM m k
441 bindSTM :: STM a -> (a -> STM b) -> STM b
442 bindSTM (STM m) k = STM ( \s ->
444 (# new_s, a #) -> unSTM (k a) new_s
447 thenSTM :: STM a -> STM b -> STM b
448 thenSTM (STM m) k = STM ( \s ->
450 (# new_s, _ #) -> unSTM k new_s
453 returnSTM :: a -> STM a
454 returnSTM x = STM (\s -> (# s, x #))
456 instance MonadPlus STM where
460 -- | Unsafely performs IO in the STM monad. Beware: this is a highly
461 -- dangerous thing to do.
463 -- * The STM implementation will often run transactions multiple
464 -- times, so you need to be prepared for this if your IO has any
467 -- * The STM implementation will abort transactions that are known to
468 -- be invalid and need to be restarted. This may happen in the middle
469 -- of `unsafeIOToSTM`, so make sure you don't acquire any resources
470 -- that need releasing (exception handlers are ignored when aborting
471 -- the transaction). That includes doing any IO using Handles, for
472 -- example. Getting this wrong will probably lead to random deadlocks.
474 -- * The transaction may have seen an inconsistent view of memory when
475 -- the IO runs. Invariants that you expect to be true throughout
476 -- your program may not be true inside a transaction, due to the
477 -- way transactions are implemented. Normally this wouldn't be visible
478 -- to the programmer, but using `unsafeIOToSTM` can expose it.
480 unsafeIOToSTM :: IO a -> STM a
481 unsafeIOToSTM (IO m) = STM m
483 -- |Perform a series of STM actions atomically.
485 -- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.
486 -- Any attempt to do so will result in a runtime error. (Reason: allowing
487 -- this would effectively allow a transaction inside a transaction, depending
488 -- on exactly when the thunk is evaluated.)
490 -- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',
491 -- and which allows top-level TVars to be allocated.
493 atomically :: STM a -> IO a
494 atomically (STM m) = IO (\s -> (atomically# m) s )
496 -- |Retry execution of the current memory transaction because it has seen
497 -- values in TVars which mean that it should not continue (e.g. the TVars
498 -- represent a shared buffer that is now empty). The implementation may
499 -- block the thread until one of the TVars that it has read from has been
500 -- udpated. (GHC only)
502 retry = STM $ \s# -> retry# s#
504 -- |Compose two alternative STM actions (GHC only). If the first action
505 -- completes without retrying then it forms the result of the orElse.
506 -- Otherwise, if the first action retries, then the second action is
507 -- tried in its place. If both actions retry then the orElse as a
509 orElse :: STM a -> STM a -> STM a
510 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
512 -- | A variant of 'throw' that can only be used within the 'STM' monad.
514 -- Throwing an exception in @STM@ aborts the transaction and propagates the
517 -- Although 'throwSTM' has a type that is an instance of the type of 'throw', the
518 -- two functions are subtly different:
520 -- > throw e `seq` x ===> throw e
521 -- > throwSTM e `seq` x ===> x
523 -- The first example will cause the exception @e@ to be raised,
524 -- whereas the second one won\'t. In fact, 'throwSTM' will only cause
525 -- an exception to be raised when it is used within the 'STM' monad.
526 -- The 'throwSTM' variant should be used in preference to 'throw' to
527 -- raise an exception within the 'STM' monad because it guarantees
528 -- ordering with respect to other 'STM' operations, whereas 'throw'
530 throwSTM :: Exception e => e -> STM a
531 throwSTM e = STM $ raiseIO# (toException e)
533 -- |Exception handling within STM actions.
534 catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
535 catchSTM (STM m) handler = STM $ catchSTM# m handler'
537 handler' e = case fromException e of
538 Just e' -> unSTM (handler e')
539 Nothing -> raiseIO# e
541 -- | Low-level primitive on which always and alwaysSucceeds are built.
542 -- checkInv differs form these in that (i) the invariant is not
543 -- checked when checkInv is called, only at the end of this and
544 -- subsequent transcations, (ii) the invariant failure is indicated
545 -- by raising an exception.
546 checkInv :: STM a -> STM ()
547 checkInv (STM m) = STM (\s -> (check# m) s)
549 -- | alwaysSucceeds adds a new invariant that must be true when passed
550 -- to alwaysSucceeds, at the end of the current transaction, and at
551 -- the end of every subsequent transaction. If it fails at any
552 -- of those points then the transaction violating it is aborted
553 -- and the exception raised by the invariant is propagated.
554 alwaysSucceeds :: STM a -> STM ()
555 alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () )
558 -- | always is a variant of alwaysSucceeds in which the invariant is
559 -- expressed as an STM Bool action that must return True. Returning
560 -- False or raising an exception are both treated as invariant failures.
561 always :: STM Bool -> STM ()
562 always i = alwaysSucceeds ( do v <- i
563 if (v) then return () else ( error "Transacional invariant violation" ) )
565 -- |Shared memory locations that support atomic memory transactions.
566 data TVar a = TVar (TVar# RealWorld a)
568 INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")
570 instance Eq (TVar a) where
571 (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
573 -- |Create a new TVar holding a value supplied
574 newTVar :: a -> STM (TVar a)
575 newTVar val = STM $ \s1# ->
576 case newTVar# val s1# of
577 (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
579 -- |@IO@ version of 'newTVar'. This is useful for creating top-level
580 -- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
581 -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
583 newTVarIO :: a -> IO (TVar a)
584 newTVarIO val = IO $ \s1# ->
585 case newTVar# val s1# of
586 (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
588 -- |Return the current value stored in a TVar.
589 -- This is equivalent to
591 -- > readTVarIO = atomically . readTVar
593 -- but works much faster, because it doesn't perform a complete
594 -- transaction, it just reads the current value of the 'TVar'.
595 readTVarIO :: TVar a -> IO a
596 readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s#
598 -- |Return the current value stored in a TVar
599 readTVar :: TVar a -> STM a
600 readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
602 -- |Write the supplied value into a TVar
603 writeTVar :: TVar a -> a -> STM ()
604 writeTVar (TVar tvar#) val = STM $ \s1# ->
605 case writeTVar# tvar# val s1# of
613 withMVar :: MVar a -> (a -> IO b) -> IO b
615 mask $ \restore -> do
617 b <- catchAny (restore (io a))
618 (\e -> do putMVar m a; throw e)
622 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
624 mask $ \restore -> do
626 a' <- catchAny (restore (io a))
627 (\e -> do putMVar m a; throw e)
632 %************************************************************************
634 \subsection{Thread waiting}
636 %************************************************************************
640 -- Machinery needed to ensureb that we only have one copy of certain
641 -- CAFs in this module even when the base package is present twice, as
642 -- it is when base is dynamically loaded into GHCi. The RTS keeps
643 -- track of the single true value of the CAF, so even when the CAFs in
644 -- the dynamically-loaded base package are reverted, nothing bad
647 sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
648 sharedCAF a get_or_set =
650 stable_ref <- newStablePtr a
651 let ref = castPtr (castStablePtrToPtr stable_ref)
652 ref2 <- get_or_set ref
655 else do freeStablePtr stable_ref
656 deRefStablePtr (castPtrToStablePtr (castPtr ref2))
658 reportStackOverflow :: IO ()
659 reportStackOverflow = callStackOverflowHook
661 reportError :: SomeException -> IO ()
663 handler <- getUncaughtExceptionHandler
666 -- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove
668 foreign import ccall unsafe "stackOverflow"
669 callStackOverflowHook :: IO ()
671 {-# NOINLINE uncaughtExceptionHandler #-}
672 uncaughtExceptionHandler :: IORef (SomeException -> IO ())
673 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
675 defaultHandler :: SomeException -> IO ()
676 defaultHandler se@(SomeException ex) = do
677 (hFlush stdout) `catchAny` (\ _ -> return ())
678 let msg = case cast ex of
679 Just Deadlock -> "no threads to run: infinite loop or deadlock?"
681 Just (ErrorCall s) -> s
682 _ -> showsPrec 0 se ""
683 withCString "%s" $ \cfmt ->
684 withCString msg $ \cmsg ->
687 -- don't use errorBelch() directly, because we cannot call varargs functions
689 foreign import ccall unsafe "HsBase.h errorBelch2"
690 errorBelch :: CString -> CString -> IO ()
692 setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
693 setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
695 getUncaughtExceptionHandler :: IO (SomeException -> IO ())
696 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler