8 , ForeignFunctionInterface
11 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
12 {-# OPTIONS_HADDOCK not-home #-}
14 -----------------------------------------------------------------------------
16 -- Module : GHC.Conc.Sync
17 -- Copyright : (c) The University of Glasgow, 1994-2002
18 -- License : see libraries/base/LICENSE
20 -- Maintainer : cvs-ghc@haskell.org
21 -- Stability : internal
22 -- Portability : non-portable (GHC extensions)
24 -- Basic concurrency stuff.
26 -----------------------------------------------------------------------------
28 -- No: #hide, because bits of this module are exposed by the stm package.
29 -- However, we don't want this module to be the home location for the
30 -- bits it exports, we'd rather have Control.Concurrent and the other
31 -- higher level modules be the home. Hence:
39 -- * Forking and suchlike
40 , forkIO -- :: IO a -> IO ThreadId
42 , forkOnIO -- :: Int -> IO a -> IO ThreadId
44 , numCapabilities -- :: Int
45 , numSparks -- :: IO Int
46 , childHandler -- :: Exception -> IO ()
47 , myThreadId -- :: IO ThreadId
48 , killThread -- :: ThreadId -> IO ()
49 , throwTo -- :: ThreadId -> Exception -> IO ()
50 , par -- :: a -> b -> b
51 , pseq -- :: a -> b -> b
54 , labelThread -- :: ThreadId -> String -> IO ()
56 , ThreadStatus(..), BlockReason(..)
57 , threadStatus -- :: ThreadId -> IO ThreadStatus
61 , atomically -- :: STM a -> IO a
63 , orElse -- :: STM a -> STM a -> STM a
64 , throwSTM -- :: Exception e => e -> STM a
65 , catchSTM -- :: Exception e => STM a -> (e -> STM a) -> STM a
66 , alwaysSucceeds -- :: STM a -> STM ()
67 , always -- :: STM Bool -> STM ()
69 , newTVar -- :: a -> STM (TVar a)
70 , newTVarIO -- :: a -> STM (TVar a)
71 , readTVar -- :: TVar a -> STM a
72 , readTVarIO -- :: TVar a -> IO a
73 , writeTVar -- :: a -> TVar a -> STM ()
74 , unsafeIOToSTM -- :: IO a -> STM a
80 , setUncaughtExceptionHandler -- :: (Exception -> IO ()) -> IO ()
81 , getUncaughtExceptionHandler -- :: IO (Exception -> IO ())
83 , reportError, reportStackOverflow
88 import Foreign hiding (unsafePerformIO)
91 #ifdef mingw32_HOST_OS
95 #ifndef mingw32_HOST_OS
102 import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
103 import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout )
105 import GHC.IO.Exception
109 import GHC.Real ( fromIntegral )
110 import GHC.Pack ( packCString# )
111 import GHC.Show ( Show(..), showString )
113 infixr 0 `par`, `pseq`
116 %************************************************************************
118 \subsection{@ThreadId@, @par@, and @fork@}
120 %************************************************************************
123 data ThreadId = ThreadId ThreadId# deriving( Typeable )
124 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
125 -- But since ThreadId# is unlifted, the Weak type must use open
128 A 'ThreadId' is an abstract type representing a handle to a thread.
129 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
130 the 'Ord' instance implements an arbitrary total ordering over
131 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
132 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
133 useful when debugging or diagnosing the behaviour of a concurrent
136 /Note/: in GHC, if you have a 'ThreadId', you essentially have
137 a pointer to the thread itself. This means the thread itself can\'t be
138 garbage collected until you drop the 'ThreadId'.
139 This misfeature will hopefully be corrected at a later date.
141 /Note/: Hugs does not provide any operations on other threads;
142 it defines 'ThreadId' as a synonym for ().
145 instance Show ThreadId where
147 showString "ThreadId " .
148 showsPrec d (getThreadId (id2TSO t))
150 foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
152 id2TSO :: ThreadId -> ThreadId#
153 id2TSO (ThreadId t) = t
155 foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
158 cmpThread :: ThreadId -> ThreadId -> Ordering
160 case cmp_thread (id2TSO t1) (id2TSO t2) of
165 instance Eq ThreadId where
167 case t1 `cmpThread` t2 of
171 instance Ord ThreadId where
175 Sparks off a new thread to run the 'IO' computation passed as the
176 first argument, and returns the 'ThreadId' of the newly created
179 The new thread will be a lightweight thread; if you want to use a foreign
180 library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead.
182 GHC note: the new thread inherits the /masked/ state of the parent
183 (see 'Control.Exception.mask').
185 The newly created thread has an exception handler that discards the
186 exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and
187 'ThreadKilled', and passes all other exceptions to the uncaught
188 exception handler (see 'setUncaughtExceptionHandler').
190 forkIO :: IO () -> IO ThreadId
191 forkIO action = IO $ \ s ->
192 case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
194 action_plus = catchException action childHandler
196 -- | Like 'forkIO', but the child thread is created with asynchronous exceptions
197 -- unmasked (see 'Control.Exception.mask').
198 forkIOUnmasked :: IO () -> IO ThreadId
199 forkIOUnmasked io = forkIO (unsafeUnmask io)
202 Like 'forkIO', but lets you specify on which CPU the thread is
203 created. Unlike a `forkIO` thread, a thread created by `forkOnIO`
204 will stay on the same CPU for its entire lifetime (`forkIO` threads
205 can migrate between CPUs according to the scheduling policy).
206 `forkOnIO` is useful for overriding the scheduling policy when you
207 know in advance how best to distribute the threads.
209 The `Int` argument specifies the CPU number; it is interpreted modulo
210 'numCapabilities' (note that it actually specifies a capability number
211 rather than a CPU number, but to a first approximation the two are
214 forkOnIO :: Int -> IO () -> IO ThreadId
215 forkOnIO (I# cpu) action = IO $ \ s ->
216 case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
218 action_plus = catchException action childHandler
220 -- | Like 'forkOnIO', but the child thread is created with
221 -- asynchronous exceptions unmasked (see 'Control.Exception.mask').
222 forkOnIOUnmasked :: Int -> IO () -> IO ThreadId
223 forkOnIOUnmasked cpu io = forkOnIO cpu (unsafeUnmask io)
225 -- | the value passed to the @+RTS -N@ flag. This is the number of
226 -- Haskell threads that can run truly simultaneously at any given
227 -- time, and is typically set to the number of physical CPU cores on
229 numCapabilities :: Int
230 numCapabilities = unsafePerformIO $ do
231 n <- peek n_capabilities
232 return (fromIntegral n)
234 -- | Returns the number of sparks currently in the local spark pool
236 numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #)
238 #if defined(mingw32_HOST_OS) && defined(__PIC__)
239 foreign import ccall "_imp__n_capabilities" n_capabilities :: Ptr CInt
241 foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt
243 childHandler :: SomeException -> IO ()
244 childHandler err = catchException (real_handler err) childHandler
246 real_handler :: SomeException -> IO ()
247 real_handler se@(SomeException ex) =
248 -- ignore thread GC and killThread exceptions:
250 Just BlockedIndefinitelyOnMVar -> return ()
252 Just BlockedIndefinitelyOnSTM -> return ()
254 Just ThreadKilled -> return ()
256 -- report all others:
257 Just StackOverflow -> reportStackOverflow
260 {- | 'killThread' raises the 'ThreadKilled' exception in the given
263 > killThread tid = throwTo tid ThreadKilled
266 killThread :: ThreadId -> IO ()
267 killThread tid = throwTo tid ThreadKilled
269 {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
271 'throwTo' does not return until the exception has been raised in the
273 The calling thread can thus be certain that the target
274 thread has received the exception. This is a useful property to know
275 when dealing with race conditions: eg. if there are two threads that
276 can kill each other, it is guaranteed that only one of the threads
277 will get to kill the other.
279 Whatever work the target thread was doing when the exception was
280 raised is not lost: the computation is suspended until required by
283 If the target thread is currently making a foreign call, then the
284 exception will not be raised (and hence 'throwTo' will not return)
285 until the call has completed. This is the case regardless of whether
286 the call is inside a 'mask' or not. However, in GHC a foreign call
287 can be annotated as @interruptible@, in which case a 'throwTo' will
288 cause the RTS to attempt to cause the call to return; see the GHC
289 documentation for more details.
291 Important note: the behaviour of 'throwTo' differs from that described in
292 the paper \"Asynchronous exceptions in Haskell\"
293 (<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>).
294 In the paper, 'throwTo' is non-blocking; but the library implementation adopts
295 a more synchronous design in which 'throwTo' does not return until the exception
296 is received by the target thread. The trade-off is discussed in Section 9 of the paper.
297 Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of
298 the paper). Unlike other interruptible operations, however, 'throwTo'
299 is /always/ interruptible, even if it does not actually block.
301 There is no guarantee that the exception will be delivered promptly,
302 although the runtime will endeavour to ensure that arbitrary
303 delays don't occur. In GHC, an exception can only be raised when a
304 thread reaches a /safe point/, where a safe point is where memory
305 allocation occurs. Some loops do not perform any memory allocation
306 inside the loop and therefore cannot be interrupted by a 'throwTo'.
308 Blocked 'throwTo' is fair: if multiple threads are trying to throw an
309 exception to the same target thread, they will succeed in FIFO order.
312 throwTo :: Exception e => ThreadId -> e -> IO ()
313 throwTo (ThreadId tid) ex = IO $ \ s ->
314 case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)
316 -- | Returns the 'ThreadId' of the calling thread (GHC only).
317 myThreadId :: IO ThreadId
318 myThreadId = IO $ \s ->
319 case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)
322 -- |The 'yield' action allows (forces, in a co-operative multitasking
323 -- implementation) a context-switch to any other currently runnable
324 -- threads (if any), and is occasionally useful when implementing
325 -- concurrency abstractions.
328 case (yield# s) of s1 -> (# s1, () #)
330 {- | 'labelThread' stores a string as identifier for this thread if
331 you built a RTS with debugging support. This identifier will be used in
332 the debugging output to make distinction of different threads easier
333 (otherwise you only have the thread state object\'s address in the heap).
335 Other applications like the graphical Concurrent Haskell Debugger
336 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
337 'labelThread' for their purposes as well.
340 labelThread :: ThreadId -> String -> IO ()
341 labelThread (ThreadId t) str = IO $ \ s ->
342 let !ps = packCString# str
343 !adr = byteArrayContents# ps in
344 case (labelThread# t adr s) of s1 -> (# s1, () #)
346 -- Nota Bene: 'pseq' used to be 'seq'
347 -- but 'seq' is now defined in PrelGHC
349 -- "pseq" is defined a bit weirdly (see below)
351 -- The reason for the strange "lazy" call is that
352 -- it fools the compiler into thinking that pseq and par are non-strict in
353 -- their second argument (even if it inlines pseq at the call site).
354 -- If it thinks pseq is strict in "y", then it often evaluates
355 -- "y" before "x", which is totally wrong.
359 pseq x y = x `seq` lazy y
363 par x y = case (par# x) of { _ -> lazy y }
365 -- | Internal function used by the RTS to run sparks.
368 where loop s = case getSpark# s of
370 if n ==# 0# then (# s', () #)
375 -- ^blocked on on 'MVar'
377 -- ^blocked on a computation in progress by another thread
379 -- ^blocked in 'throwTo'
381 -- ^blocked in 'retry' in an STM transaction
382 | BlockedOnForeignCall
383 -- ^currently in a foreign call
385 -- ^blocked on some other resource. Without @-threaded@,
386 -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
387 -- they show up as 'BlockedOnMVar'.
388 deriving (Eq,Ord,Show)
390 -- | The current status of a thread
393 -- ^the thread is currently runnable or running
395 -- ^the thread has finished
396 | ThreadBlocked BlockReason
397 -- ^the thread is blocked on some resource
399 -- ^the thread received an uncaught exception
400 deriving (Eq,Ord,Show)
402 threadStatus :: ThreadId -> IO ThreadStatus
403 threadStatus (ThreadId t) = IO $ \s ->
404 case threadStatus# t s of
405 (# s', stat #) -> (# s', mk_stat (I# stat) #)
407 -- NB. keep these in sync with includes/Constants.h
408 mk_stat 0 = ThreadRunning
409 mk_stat 1 = ThreadBlocked BlockedOnMVar
410 mk_stat 2 = ThreadBlocked BlockedOnBlackHole
411 mk_stat 3 = ThreadBlocked BlockedOnException
412 mk_stat 7 = ThreadBlocked BlockedOnSTM
413 mk_stat 11 = ThreadBlocked BlockedOnForeignCall
414 mk_stat 12 = ThreadBlocked BlockedOnForeignCall
415 mk_stat 16 = ThreadFinished
416 mk_stat 17 = ThreadDied
417 mk_stat _ = ThreadBlocked BlockedOnOther
421 %************************************************************************
423 \subsection[stm]{Transactional heap operations}
425 %************************************************************************
427 TVars are shared memory locations which support atomic memory
431 -- |A monad supporting atomic memory transactions.
432 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
434 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
437 INSTANCE_TYPEABLE1(STM,stmTc,"STM")
439 instance Functor STM where
440 fmap f x = x >>= (return . f)
442 instance Monad STM where
443 {-# INLINE return #-}
447 return x = returnSTM x
448 m >>= k = bindSTM m k
450 bindSTM :: STM a -> (a -> STM b) -> STM b
451 bindSTM (STM m) k = STM ( \s ->
453 (# new_s, a #) -> unSTM (k a) new_s
456 thenSTM :: STM a -> STM b -> STM b
457 thenSTM (STM m) k = STM ( \s ->
459 (# new_s, _ #) -> unSTM k new_s
462 returnSTM :: a -> STM a
463 returnSTM x = STM (\s -> (# s, x #))
465 instance MonadPlus STM where
469 -- | Unsafely performs IO in the STM monad. Beware: this is a highly
470 -- dangerous thing to do.
472 -- * The STM implementation will often run transactions multiple
473 -- times, so you need to be prepared for this if your IO has any
476 -- * The STM implementation will abort transactions that are known to
477 -- be invalid and need to be restarted. This may happen in the middle
478 -- of `unsafeIOToSTM`, so make sure you don't acquire any resources
479 -- that need releasing (exception handlers are ignored when aborting
480 -- the transaction). That includes doing any IO using Handles, for
481 -- example. Getting this wrong will probably lead to random deadlocks.
483 -- * The transaction may have seen an inconsistent view of memory when
484 -- the IO runs. Invariants that you expect to be true throughout
485 -- your program may not be true inside a transaction, due to the
486 -- way transactions are implemented. Normally this wouldn't be visible
487 -- to the programmer, but using `unsafeIOToSTM` can expose it.
489 unsafeIOToSTM :: IO a -> STM a
490 unsafeIOToSTM (IO m) = STM m
492 -- |Perform a series of STM actions atomically.
494 -- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.
495 -- Any attempt to do so will result in a runtime error. (Reason: allowing
496 -- this would effectively allow a transaction inside a transaction, depending
497 -- on exactly when the thunk is evaluated.)
499 -- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',
500 -- and which allows top-level TVars to be allocated.
502 atomically :: STM a -> IO a
503 atomically (STM m) = IO (\s -> (atomically# m) s )
505 -- |Retry execution of the current memory transaction because it has seen
506 -- values in TVars which mean that it should not continue (e.g. the TVars
507 -- represent a shared buffer that is now empty). The implementation may
508 -- block the thread until one of the TVars that it has read from has been
509 -- udpated. (GHC only)
511 retry = STM $ \s# -> retry# s#
513 -- |Compose two alternative STM actions (GHC only). If the first action
514 -- completes without retrying then it forms the result of the orElse.
515 -- Otherwise, if the first action retries, then the second action is
516 -- tried in its place. If both actions retry then the orElse as a
518 orElse :: STM a -> STM a -> STM a
519 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
521 -- | A variant of 'throw' that can only be used within the 'STM' monad.
523 -- Throwing an exception in @STM@ aborts the transaction and propagates the
526 -- Although 'throwSTM' has a type that is an instance of the type of 'throw', the
527 -- two functions are subtly different:
529 -- > throw e `seq` x ===> throw e
530 -- > throwSTM e `seq` x ===> x
532 -- The first example will cause the exception @e@ to be raised,
533 -- whereas the second one won\'t. In fact, 'throwSTM' will only cause
534 -- an exception to be raised when it is used within the 'STM' monad.
535 -- The 'throwSTM' variant should be used in preference to 'throw' to
536 -- raise an exception within the 'STM' monad because it guarantees
537 -- ordering with respect to other 'STM' operations, whereas 'throw'
539 throwSTM :: Exception e => e -> STM a
540 throwSTM e = STM $ raiseIO# (toException e)
542 -- |Exception handling within STM actions.
543 catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
544 catchSTM (STM m) handler = STM $ catchSTM# m handler'
546 handler' e = case fromException e of
547 Just e' -> unSTM (handler e')
548 Nothing -> raiseIO# e
550 -- | Low-level primitive on which always and alwaysSucceeds are built.
551 -- checkInv differs form these in that (i) the invariant is not
552 -- checked when checkInv is called, only at the end of this and
553 -- subsequent transcations, (ii) the invariant failure is indicated
554 -- by raising an exception.
555 checkInv :: STM a -> STM ()
556 checkInv (STM m) = STM (\s -> (check# m) s)
558 -- | alwaysSucceeds adds a new invariant that must be true when passed
559 -- to alwaysSucceeds, at the end of the current transaction, and at
560 -- the end of every subsequent transaction. If it fails at any
561 -- of those points then the transaction violating it is aborted
562 -- and the exception raised by the invariant is propagated.
563 alwaysSucceeds :: STM a -> STM ()
564 alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () )
567 -- | always is a variant of alwaysSucceeds in which the invariant is
568 -- expressed as an STM Bool action that must return True. Returning
569 -- False or raising an exception are both treated as invariant failures.
570 always :: STM Bool -> STM ()
571 always i = alwaysSucceeds ( do v <- i
572 if (v) then return () else ( error "Transacional invariant violation" ) )
574 -- |Shared memory locations that support atomic memory transactions.
575 data TVar a = TVar (TVar# RealWorld a)
577 INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")
579 instance Eq (TVar a) where
580 (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
582 -- |Create a new TVar holding a value supplied
583 newTVar :: a -> STM (TVar a)
584 newTVar val = STM $ \s1# ->
585 case newTVar# val s1# of
586 (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
588 -- |@IO@ version of 'newTVar'. This is useful for creating top-level
589 -- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
590 -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
592 newTVarIO :: a -> IO (TVar a)
593 newTVarIO val = IO $ \s1# ->
594 case newTVar# val s1# of
595 (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
597 -- |Return the current value stored in a TVar.
598 -- This is equivalent to
600 -- > readTVarIO = atomically . readTVar
602 -- but works much faster, because it doesn't perform a complete
603 -- transaction, it just reads the current value of the 'TVar'.
604 readTVarIO :: TVar a -> IO a
605 readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s#
607 -- |Return the current value stored in a TVar
608 readTVar :: TVar a -> STM a
609 readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
611 -- |Write the supplied value into a TVar
612 writeTVar :: TVar a -> a -> STM ()
613 writeTVar (TVar tvar#) val = STM $ \s1# ->
614 case writeTVar# tvar# val s1# of
622 withMVar :: MVar a -> (a -> IO b) -> IO b
624 mask $ \restore -> do
626 b <- catchAny (restore (io a))
627 (\e -> do putMVar m a; throw e)
631 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
633 mask $ \restore -> do
635 a' <- catchAny (restore (io a))
636 (\e -> do putMVar m a; throw e)
641 %************************************************************************
643 \subsection{Thread waiting}
645 %************************************************************************
649 -- Machinery needed to ensureb that we only have one copy of certain
650 -- CAFs in this module even when the base package is present twice, as
651 -- it is when base is dynamically loaded into GHCi. The RTS keeps
652 -- track of the single true value of the CAF, so even when the CAFs in
653 -- the dynamically-loaded base package are reverted, nothing bad
656 sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
657 sharedCAF a get_or_set =
659 stable_ref <- newStablePtr a
660 let ref = castPtr (castStablePtrToPtr stable_ref)
661 ref2 <- get_or_set ref
664 else do freeStablePtr stable_ref
665 deRefStablePtr (castPtrToStablePtr (castPtr ref2))
667 reportStackOverflow :: IO ()
668 reportStackOverflow = callStackOverflowHook
670 reportError :: SomeException -> IO ()
672 handler <- getUncaughtExceptionHandler
675 -- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove
677 foreign import ccall unsafe "stackOverflow"
678 callStackOverflowHook :: IO ()
680 {-# NOINLINE uncaughtExceptionHandler #-}
681 uncaughtExceptionHandler :: IORef (SomeException -> IO ())
682 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
684 defaultHandler :: SomeException -> IO ()
685 defaultHandler se@(SomeException ex) = do
686 (hFlush stdout) `catchAny` (\ _ -> return ())
687 let msg = case cast ex of
688 Just Deadlock -> "no threads to run: infinite loop or deadlock?"
690 Just (ErrorCall s) -> s
691 _ -> showsPrec 0 se ""
692 withCString "%s" $ \cfmt ->
693 withCString msg $ \cmsg ->
696 -- don't use errorBelch() directly, because we cannot call varargs functions
698 foreign import ccall unsafe "HsBase.h errorBelch2"
699 errorBelch :: CString -> CString -> IO ()
701 setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
702 setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
704 getUncaughtExceptionHandler :: IO (SomeException -> IO ())
705 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler