Add Haddock `/Since: 4.5.[01].0/` comments to symbols
[packages/base.git] / GHC / Conc / Sync.lhs
1 \begin{code}
2 {-# LANGUAGE Unsafe #-}
3 {-# LANGUAGE CPP
4            , NoImplicitPrelude
5            , BangPatterns
6            , MagicHash
7            , UnboxedTuples
8            , UnliftedFFITypes
9            , ForeignFunctionInterface
10            , DeriveDataTypeable
11            , StandaloneDeriving
12            , RankNTypes
13            , PatternGuards
14   #-}
15 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
16 {-# OPTIONS_HADDOCK not-home #-}
17
18 -----------------------------------------------------------------------------
19 -- |
20 -- Module      :  GHC.Conc.Sync
21 -- Copyright   :  (c) The University of Glasgow, 1994-2002
22 -- License     :  see libraries/base/LICENSE
23 --
24 -- Maintainer  :  cvs-ghc@haskell.org
25 -- Stability   :  internal
26 -- Portability :  non-portable (GHC extensions)
27 --
28 -- Basic concurrency stuff.
29 --
30 -----------------------------------------------------------------------------
31
32 -- No: #hide, because bits of this module are exposed by the stm package.
33 -- However, we don't want this module to be the home location for the
34 -- bits it exports, we'd rather have Control.Concurrent and the other
35 -- higher level modules be the home.  Hence:
36
37 -- #not-home
38 module GHC.Conc.Sync
39         ( ThreadId(..)
40
41         -- * Forking and suchlike
42         , forkIO
43         , forkIOWithUnmask
44         , forkOn
45         , forkOnWithUnmask
46         , numCapabilities
47         , getNumCapabilities
48         , setNumCapabilities
49         , getNumProcessors
50         , numSparks
51         , childHandler
52         , myThreadId
53         , killThread
54         , throwTo
55         , par
56         , pseq
57         , runSparks
58         , yield
59         , labelThread
60         , mkWeakThreadId
61
62         , ThreadStatus(..), BlockReason(..)
63         , threadStatus
64         , threadCapability
65
66         -- * TVars
67         , STM(..)
68         , atomically
69         , retry
70         , orElse
71         , throwSTM
72         , catchSTM
73         , alwaysSucceeds
74         , always
75         , TVar(..)
76         , newTVar
77         , newTVarIO
78         , readTVar
79         , readTVarIO
80         , writeTVar
81         , unsafeIOToSTM
82
83         -- * Miscellaneous
84         , withMVar
85         , modifyMVar_
86
87         , setUncaughtExceptionHandler
88         , getUncaughtExceptionHandler
89
90         , reportError, reportStackOverflow
91
92         , sharedCAF
93         ) where
94
95 import Foreign
96 import Foreign.C
97
98 #ifdef mingw32_HOST_OS
99 import Data.Typeable
100 #endif
101
102 #ifndef mingw32_HOST_OS
103 import Data.Dynamic
104 #endif
105 import Control.Monad
106 import Data.Maybe
107
108 import GHC.Base
109 import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
110 import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout )
111 import GHC.IO
112 import GHC.IO.Encoding.UTF8
113 import GHC.IO.Exception
114 import GHC.Exception
115 import qualified GHC.Foreign
116 import GHC.IORef
117 import GHC.MVar
118 import GHC.Ptr
119 import GHC.Real         ( fromIntegral )
120 import GHC.Show         ( Show(..), showString )
121 import GHC.Weak
122
123 infixr 0 `par`, `pseq`
124 \end{code}
125
126 %************************************************************************
127 %*                                                                      *
128 \subsection{@ThreadId@, @par@, and @fork@}
129 %*                                                                      *
130 %************************************************************************
131
132 \begin{code}
133 data ThreadId = ThreadId ThreadId# deriving( Typeable )
134 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
135 -- But since ThreadId# is unlifted, the Weak type must use open
136 -- type variables.
137 {- ^
138 A 'ThreadId' is an abstract type representing a handle to a thread.
139 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
140 the 'Ord' instance implements an arbitrary total ordering over
141 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
142 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
143 useful when debugging or diagnosing the behaviour of a concurrent
144 program.
145
146 /Note/: in GHC, if you have a 'ThreadId', you essentially have
147 a pointer to the thread itself.  This means the thread itself can\'t be
148 garbage collected until you drop the 'ThreadId'.
149 This misfeature will hopefully be corrected at a later date.
150
151 -}
152
153 instance Show ThreadId where
154    showsPrec d t =
155         showString "ThreadId " .
156         showsPrec d (getThreadId (id2TSO t))
157
158 foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
159
160 id2TSO :: ThreadId -> ThreadId#
161 id2TSO (ThreadId t) = t
162
163 foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
164 -- Returns -1, 0, 1
165
166 cmpThread :: ThreadId -> ThreadId -> Ordering
167 cmpThread t1 t2 =
168    case cmp_thread (id2TSO t1) (id2TSO t2) of
169       -1 -> LT
170       0  -> EQ
171       _  -> GT -- must be 1
172
173 instance Eq ThreadId where
174    t1 == t2 =
175       case t1 `cmpThread` t2 of
176          EQ -> True
177          _  -> False
178
179 instance Ord ThreadId where
180    compare = cmpThread
181
182 {- |
183 Sparks off a new thread to run the 'IO' computation passed as the
184 first argument, and returns the 'ThreadId' of the newly created
185 thread.
186
187 The new thread will be a lightweight thread; if you want to use a foreign
188 library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead.
189
190 GHC note: the new thread inherits the /masked/ state of the parent
191 (see 'Control.Exception.mask').
192
193 The newly created thread has an exception handler that discards the
194 exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and
195 'ThreadKilled', and passes all other exceptions to the uncaught
196 exception handler.
197 -}
198 forkIO :: IO () -> IO ThreadId
199 forkIO action = IO $ \ s ->
200    case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
201  where
202   action_plus = catchException action childHandler
203
204 -- | Like 'forkIO', but the child thread is passed a function that can
205 -- be used to unmask asynchronous exceptions.  This function is
206 -- typically used in the following way
207 --
208 -- >  ... mask_ $ forkIOWithUnmask $ \unmask ->
209 -- >                 catch (unmask ...) handler
210 --
211 -- so that the exception handler in the child thread is established
212 -- with asynchronous exceptions masked, meanwhile the main body of
213 -- the child thread is executed in the unmasked state.
214 --
215 -- Note that the unmask function passed to the child thread should
216 -- only be used in that thread; the behaviour is undefined if it is
217 -- invoked in a different thread.
218 --
219 forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
220 forkIOWithUnmask io = forkIO (io unsafeUnmask)
221
222 {- |
223 Like 'forkIO', but lets you specify on which processor the thread
224 should run.  Unlike a `forkIO` thread, a thread created by `forkOn`
225 will stay on the same processor for its entire lifetime (`forkIO`
226 threads can migrate between processors according to the scheduling
227 policy).  `forkOn` is useful for overriding the scheduling policy when
228 you know in advance how best to distribute the threads.
229
230 The `Int` argument specifies a /capability number/ (see
231 'getNumCapabilities').  Typically capabilities correspond to physical
232 processors, but the exact behaviour is implementation-dependent.  The
233 value passed to 'forkOn' is interpreted modulo the total number of
234 capabilities as returned by 'getNumCapabilities'.
235
236 GHC note: the number of capabilities is specified by the @+RTS -N@
237 option when the program is started.  Capabilities can be fixed to
238 actual processor cores with @+RTS -qa@ if the underlying operating
239 system supports that, although in practice this is usually unnecessary
240 (and may actually degrade performance in some cases - experimentation
241 is recommended).
242 -}
243 forkOn :: Int -> IO () -> IO ThreadId
244 forkOn (I# cpu) action = IO $ \ s ->
245    case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
246  where
247   action_plus = catchException action childHandler
248
249 -- | Like 'forkIOWithUnmask', but the child thread is pinned to the
250 -- given CPU, as with 'forkOn'.
251 forkOnWithUnmask :: Int -> ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
252 forkOnWithUnmask cpu io = forkOn cpu (io unsafeUnmask)
253
254 -- | the value passed to the @+RTS -N@ flag.  This is the number of
255 -- Haskell threads that can run truly simultaneously at any given
256 -- time, and is typically set to the number of physical processor cores on
257 -- the machine.
258 --
259 -- Strictly speaking it is better to use 'getNumCapabilities', because
260 -- the number of capabilities might vary at runtime.
261 --
262 numCapabilities :: Int
263 numCapabilities = unsafePerformIO $ getNumCapabilities
264
265 {- |
266 Returns the number of Haskell threads that can run truly
267 simultaneously (on separate physical processors) at any given time.  To change
268 this value, use 'setNumCapabilities'.
269 -}
270 getNumCapabilities :: IO Int
271 getNumCapabilities = do
272    n <- peek enabled_capabilities
273    return (fromIntegral n)
274
275 {- |
276 Set the number of Haskell threads that can run truly simultaneously
277 (on separate physical processors) at any given time.  The number
278 passed to `forkOn` is interpreted modulo this value.  The initial
279 value is given by the @+RTS -N@ runtime flag.
280
281 This is also the number of threads that will participate in parallel
282 garbage collection.  It is strongly recommended that the number of
283 capabilities is not set larger than the number of physical processor
284 cores, and it may often be beneficial to leave one or more cores free
285 to avoid contention with other processes in the machine.
286
287 /Since: 4.5.0.0/
288 -}
289 setNumCapabilities :: Int -> IO ()
290 setNumCapabilities i = c_setNumCapabilities (fromIntegral i)
291
292 foreign import ccall safe "setNumCapabilities"
293   c_setNumCapabilities :: CUInt -> IO ()
294
295 -- | Returns the number of CPUs that the machine has
296 --
297 -- /Since: 4.5.0.0/
298 getNumProcessors :: IO Int
299 getNumProcessors = fmap fromIntegral c_getNumberOfProcessors
300
301 foreign import ccall unsafe "getNumberOfProcessors"
302   c_getNumberOfProcessors :: IO CUInt
303
304 -- | Returns the number of sparks currently in the local spark pool
305 numSparks :: IO Int
306 numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #)
307
308 foreign import ccall "&enabled_capabilities" enabled_capabilities :: Ptr CInt
309
310 childHandler :: SomeException -> IO ()
311 childHandler err = catchException (real_handler err) childHandler
312
313 real_handler :: SomeException -> IO ()
314 real_handler se
315   | Just BlockedIndefinitelyOnMVar <- fromException se  =  return ()
316   | Just BlockedIndefinitelyOnSTM  <- fromException se  =  return ()
317   | Just ThreadKilled              <- fromException se  =  return ()
318   | Just StackOverflow             <- fromException se  =  reportStackOverflow
319   | otherwise                                           =  reportError se
320
321 {- | 'killThread' raises the 'ThreadKilled' exception in the given
322 thread (GHC only).
323
324 > killThread tid = throwTo tid ThreadKilled
325
326 -}
327 killThread :: ThreadId -> IO ()
328 killThread tid = throwTo tid ThreadKilled
329
330 {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
331
332 'throwTo' does not return until the exception has been raised in the
333 target thread.
334 The calling thread can thus be certain that the target
335 thread has received the exception.  This is a useful property to know
336 when dealing with race conditions: eg. if there are two threads that
337 can kill each other, it is guaranteed that only one of the threads
338 will get to kill the other.
339
340 Whatever work the target thread was doing when the exception was
341 raised is not lost: the computation is suspended until required by
342 another thread.
343
344 If the target thread is currently making a foreign call, then the
345 exception will not be raised (and hence 'throwTo' will not return)
346 until the call has completed.  This is the case regardless of whether
347 the call is inside a 'mask' or not.  However, in GHC a foreign call
348 can be annotated as @interruptible@, in which case a 'throwTo' will
349 cause the RTS to attempt to cause the call to return; see the GHC
350 documentation for more details.
351
352 Important note: the behaviour of 'throwTo' differs from that described in
353 the paper \"Asynchronous exceptions in Haskell\"
354 (<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>).
355 In the paper, 'throwTo' is non-blocking; but the library implementation adopts
356 a more synchronous design in which 'throwTo' does not return until the exception
357 is received by the target thread.  The trade-off is discussed in Section 9 of the paper.
358 Like any blocking operation, 'throwTo' is therefore interruptible (see Section 5.3 of
359 the paper).  Unlike other interruptible operations, however, 'throwTo'
360 is /always/ interruptible, even if it does not actually block.
361
362 There is no guarantee that the exception will be delivered promptly,
363 although the runtime will endeavour to ensure that arbitrary
364 delays don't occur.  In GHC, an exception can only be raised when a
365 thread reaches a /safe point/, where a safe point is where memory
366 allocation occurs.  Some loops do not perform any memory allocation
367 inside the loop and therefore cannot be interrupted by a 'throwTo'.
368
369 If the target of 'throwTo' is the calling thread, then the behaviour
370 is the same as 'Control.Exception.throwIO', except that the exception
371 is thrown as an asynchronous exception.  This means that if there is
372 an enclosing pure computation, which would be the case if the current
373 IO operation is inside 'unsafePerformIO' or 'unsafeInterleaveIO', that
374 computation is not permanently replaced by the exception, but is
375 suspended as if it had received an asynchronous exception.
376
377 Note that if 'throwTo' is called with the current thread as the
378 target, the exception will be thrown even if the thread is currently
379 inside 'mask' or 'uninterruptibleMask'.
380   -}
381 throwTo :: Exception e => ThreadId -> e -> IO ()
382 throwTo (ThreadId tid) ex = IO $ \ s ->
383    case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)
384
385 -- | Returns the 'ThreadId' of the calling thread (GHC only).
386 myThreadId :: IO ThreadId
387 myThreadId = IO $ \s ->
388    case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)
389
390
391 -- |The 'yield' action allows (forces, in a co-operative multitasking
392 -- implementation) a context-switch to any other currently runnable
393 -- threads (if any), and is occasionally useful when implementing
394 -- concurrency abstractions.
395 yield :: IO ()
396 yield = IO $ \s ->
397    case (yield# s) of s1 -> (# s1, () #)
398
399 {- | 'labelThread' stores a string as identifier for this thread if
400 you built a RTS with debugging support. This identifier will be used in
401 the debugging output to make distinction of different threads easier
402 (otherwise you only have the thread state object\'s address in the heap).
403
404 Other applications like the graphical Concurrent Haskell Debugger
405 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
406 'labelThread' for their purposes as well.
407 -}
408
409 labelThread :: ThreadId -> String -> IO ()
410 labelThread (ThreadId t) str =
411     GHC.Foreign.withCString utf8 str $ \(Ptr p) ->
412     IO $ \ s ->
413      case labelThread# t p s of s1 -> (# s1, () #)
414
415 --      Nota Bene: 'pseq' used to be 'seq'
416 --                 but 'seq' is now defined in PrelGHC
417 --
418 -- "pseq" is defined a bit weirdly (see below)
419 --
420 -- The reason for the strange "lazy" call is that
421 -- it fools the compiler into thinking that pseq  and par are non-strict in
422 -- their second argument (even if it inlines pseq at the call site).
423 -- If it thinks pseq is strict in "y", then it often evaluates
424 -- "y" before "x", which is totally wrong.
425
426 {-# INLINE pseq  #-}
427 pseq :: a -> b -> b
428 pseq  x y = x `seq` lazy y
429
430 {-# INLINE par  #-}
431 par :: a -> b -> b
432 par  x y = case (par# x) of { _ -> lazy y }
433
434 -- | Internal function used by the RTS to run sparks.
435 runSparks :: IO ()
436 runSparks = IO loop
437   where loop s = case getSpark# s of
438                    (# s', n, p #) ->
439                       if isTrue# (n ==# 0#)
440                       then (# s', () #)
441                       else p `seq` loop s'
442
443 data BlockReason
444   = BlockedOnMVar
445         -- ^blocked on on 'MVar'
446   | BlockedOnBlackHole
447         -- ^blocked on a computation in progress by another thread
448   | BlockedOnException
449         -- ^blocked in 'throwTo'
450   | BlockedOnSTM
451         -- ^blocked in 'retry' in an STM transaction
452   | BlockedOnForeignCall
453         -- ^currently in a foreign call
454   | BlockedOnOther
455         -- ^blocked on some other resource.  Without @-threaded@,
456         -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
457         -- they show up as 'BlockedOnMVar'.
458   deriving (Eq,Ord,Show)
459
460 -- | The current status of a thread
461 data ThreadStatus
462   = ThreadRunning
463         -- ^the thread is currently runnable or running
464   | ThreadFinished
465         -- ^the thread has finished
466   | ThreadBlocked  BlockReason
467         -- ^the thread is blocked on some resource
468   | ThreadDied
469         -- ^the thread received an uncaught exception
470   deriving (Eq,Ord,Show)
471
472 threadStatus :: ThreadId -> IO ThreadStatus
473 threadStatus (ThreadId t) = IO $ \s ->
474    case threadStatus# t s of
475     (# s', stat, _cap, _locked #) -> (# s', mk_stat (I# stat) #)
476    where
477         -- NB. keep these in sync with includes/Constants.h
478      mk_stat 0  = ThreadRunning
479      mk_stat 1  = ThreadBlocked BlockedOnMVar
480      mk_stat 2  = ThreadBlocked BlockedOnMVar -- XXX distinguish?
481      mk_stat 3  = ThreadBlocked BlockedOnBlackHole
482      mk_stat 7  = ThreadBlocked BlockedOnSTM
483      mk_stat 11 = ThreadBlocked BlockedOnForeignCall
484      mk_stat 12 = ThreadBlocked BlockedOnForeignCall
485      mk_stat 13 = ThreadBlocked BlockedOnException
486      -- NB. these are hardcoded in rts/PrimOps.cmm
487      mk_stat 16 = ThreadFinished
488      mk_stat 17 = ThreadDied
489      mk_stat _  = ThreadBlocked BlockedOnOther
490
491 -- | returns the number of the capability on which the thread is currently
492 -- running, and a boolean indicating whether the thread is locked to
493 -- that capability or not.  A thread is locked to a capability if it
494 -- was created with @forkOn@.
495 threadCapability :: ThreadId -> IO (Int, Bool)
496 threadCapability (ThreadId t) = IO $ \s ->
497    case threadStatus# t s of
498      (# s', _, cap#, locked# #) -> (# s', (I# cap#, isTrue# (locked# /=# 0#)) #)
499
500 -- | make a weak pointer to a 'ThreadId'.  It can be important to do
501 -- this if you want to hold a reference to a 'ThreadId' while still
502 -- allowing the thread to receive the @BlockedIndefinitely@ family of
503 -- exceptions (e.g. 'BlockedIndefinitelyOnMVar').  Holding a normal
504 -- 'ThreadId' reference will prevent the delivery of
505 -- @BlockedIndefinitely@ exceptions because the reference could be
506 -- used as the target of 'throwTo' at any time, which would unblock
507 -- the thread.
508 --
509 -- Holding a @Weak ThreadId@, on the other hand, will not prevent the
510 -- thread from receiving @BlockedIndefinitely@ exceptions.  It is
511 -- still possible to throw an exception to a @Weak ThreadId@, but the
512 -- caller must use @deRefWeak@ first to determine whether the thread
513 -- still exists.
514 --
515 -- /Since: 4.6.0.0/
516 mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
517 mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
518    case mkWeakNoFinalizer# t# t s of
519       (# s1, w #) -> (# s1, Weak w #)
520 \end{code}
521
522
523 %************************************************************************
524 %*                                                                      *
525 \subsection[stm]{Transactional heap operations}
526 %*                                                                      *
527 %************************************************************************
528
529 TVars are shared memory locations which support atomic memory
530 transactions.
531
532 \begin{code}
533 -- |A monad supporting atomic memory transactions.
534 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
535                 deriving Typeable
536
537 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
538 unSTM (STM a) = a
539
540 instance  Functor STM where
541    fmap f x = x >>= (return . f)
542
543 instance  Monad STM  where
544     {-# INLINE return #-}
545     {-# INLINE (>>)   #-}
546     {-# INLINE (>>=)  #-}
547     m >> k      = thenSTM m k
548     return x    = returnSTM x
549     m >>= k     = bindSTM m k
550
551 bindSTM :: STM a -> (a -> STM b) -> STM b
552 bindSTM (STM m) k = STM ( \s ->
553   case m s of
554     (# new_s, a #) -> unSTM (k a) new_s
555   )
556
557 thenSTM :: STM a -> STM b -> STM b
558 thenSTM (STM m) k = STM ( \s ->
559   case m s of
560     (# new_s, _ #) -> unSTM k new_s
561   )
562
563 returnSTM :: a -> STM a
564 returnSTM x = STM (\s -> (# s, x #))
565
566 instance MonadPlus STM where
567   mzero = retry
568   mplus = orElse
569
570 -- | Unsafely performs IO in the STM monad.  Beware: this is a highly
571 -- dangerous thing to do.
572 --
573 --   * The STM implementation will often run transactions multiple
574 --     times, so you need to be prepared for this if your IO has any
575 --     side effects.
576 --
577 --   * The STM implementation will abort transactions that are known to
578 --     be invalid and need to be restarted.  This may happen in the middle
579 --     of `unsafeIOToSTM`, so make sure you don't acquire any resources
580 --     that need releasing (exception handlers are ignored when aborting
581 --     the transaction).  That includes doing any IO using Handles, for
582 --     example.  Getting this wrong will probably lead to random deadlocks.
583 --
584 --   * The transaction may have seen an inconsistent view of memory when
585 --     the IO runs.  Invariants that you expect to be true throughout
586 --     your program may not be true inside a transaction, due to the
587 --     way transactions are implemented.  Normally this wouldn't be visible
588 --     to the programmer, but using `unsafeIOToSTM` can expose it.
589 --
590 unsafeIOToSTM :: IO a -> STM a
591 unsafeIOToSTM (IO m) = STM m
592
593 -- |Perform a series of STM actions atomically.
594 --
595 -- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.
596 -- Any attempt to do so will result in a runtime error.  (Reason: allowing
597 -- this would effectively allow a transaction inside a transaction, depending
598 -- on exactly when the thunk is evaluated.)
599 --
600 -- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',
601 -- and which allows top-level TVars to be allocated.
602
603 atomically :: STM a -> IO a
604 atomically (STM m) = IO (\s -> (atomically# m) s )
605
606 -- |Retry execution of the current memory transaction because it has seen
607 -- values in TVars which mean that it should not continue (e.g. the TVars
608 -- represent a shared buffer that is now empty).  The implementation may
609 -- block the thread until one of the TVars that it has read from has been
610 -- udpated. (GHC only)
611 retry :: STM a
612 retry = STM $ \s# -> retry# s#
613
614 -- |Compose two alternative STM actions (GHC only).  If the first action
615 -- completes without retrying then it forms the result of the orElse.
616 -- Otherwise, if the first action retries, then the second action is
617 -- tried in its place.  If both actions retry then the orElse as a
618 -- whole retries.
619 orElse :: STM a -> STM a -> STM a
620 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
621
622 -- | A variant of 'throw' that can only be used within the 'STM' monad.
623 --
624 -- Throwing an exception in @STM@ aborts the transaction and propagates the
625 -- exception.
626 --
627 -- Although 'throwSTM' has a type that is an instance of the type of 'throw', the
628 -- two functions are subtly different:
629 --
630 -- > throw e    `seq` x  ===> throw e
631 -- > throwSTM e `seq` x  ===> x
632 --
633 -- The first example will cause the exception @e@ to be raised,
634 -- whereas the second one won\'t.  In fact, 'throwSTM' will only cause
635 -- an exception to be raised when it is used within the 'STM' monad.
636 -- The 'throwSTM' variant should be used in preference to 'throw' to
637 -- raise an exception within the 'STM' monad because it guarantees
638 -- ordering with respect to other 'STM' operations, whereas 'throw'
639 -- does not.
640 throwSTM :: Exception e => e -> STM a
641 throwSTM e = STM $ raiseIO# (toException e)
642
643 -- |Exception handling within STM actions.
644 catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
645 catchSTM (STM m) handler = STM $ catchSTM# m handler'
646     where
647       handler' e = case fromException e of
648                      Just e' -> unSTM (handler e')
649                      Nothing -> raiseIO# e
650
651 -- | Low-level primitive on which always and alwaysSucceeds are built.
652 -- checkInv differs form these in that (i) the invariant is not
653 -- checked when checkInv is called, only at the end of this and
654 -- subsequent transcations, (ii) the invariant failure is indicated
655 -- by raising an exception.
656 checkInv :: STM a -> STM ()
657 checkInv (STM m) = STM (\s -> (check# m) s)
658
659 -- | alwaysSucceeds adds a new invariant that must be true when passed
660 -- to alwaysSucceeds, at the end of the current transaction, and at
661 -- the end of every subsequent transaction.  If it fails at any
662 -- of those points then the transaction violating it is aborted
663 -- and the exception raised by the invariant is propagated.
664 alwaysSucceeds :: STM a -> STM ()
665 alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () )
666                       checkInv i
667
668 -- | always is a variant of alwaysSucceeds in which the invariant is
669 -- expressed as an STM Bool action that must return True.  Returning
670 -- False or raising an exception are both treated as invariant failures.
671 always :: STM Bool -> STM ()
672 always i = alwaysSucceeds ( do v <- i
673                                if (v) then return () else ( error "Transactional invariant violation" ) )
674
675 -- |Shared memory locations that support atomic memory transactions.
676 data TVar a = TVar (TVar# RealWorld a)
677               deriving Typeable
678
679 instance Eq (TVar a) where
680         (TVar tvar1#) == (TVar tvar2#) = isTrue# (sameTVar# tvar1# tvar2#)
681
682 -- |Create a new TVar holding a value supplied
683 newTVar :: a -> STM (TVar a)
684 newTVar val = STM $ \s1# ->
685     case newTVar# val s1# of
686          (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
687
688 -- |@IO@ version of 'newTVar'.  This is useful for creating top-level
689 -- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
690 -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
691 -- possible.
692 newTVarIO :: a -> IO (TVar a)
693 newTVarIO val = IO $ \s1# ->
694     case newTVar# val s1# of
695          (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
696
697 -- |Return the current value stored in a TVar.
698 -- This is equivalent to
699 --
700 -- >  readTVarIO = atomically . readTVar
701 --
702 -- but works much faster, because it doesn't perform a complete
703 -- transaction, it just reads the current value of the 'TVar'.
704 readTVarIO :: TVar a -> IO a
705 readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s#
706
707 -- |Return the current value stored in a TVar
708 readTVar :: TVar a -> STM a
709 readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
710
711 -- |Write the supplied value into a TVar
712 writeTVar :: TVar a -> a -> STM ()
713 writeTVar (TVar tvar#) val = STM $ \s1# ->
714     case writeTVar# tvar# val s1# of
715          s2# -> (# s2#, () #)
716
717 \end{code}
718
719 MVar utilities
720
721 \begin{code}
722 withMVar :: MVar a -> (a -> IO b) -> IO b
723 withMVar m io =
724   mask $ \restore -> do
725     a <- takeMVar m
726     b <- catchAny (restore (io a))
727             (\e -> do putMVar m a; throw e)
728     putMVar m a
729     return b
730
731 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
732 modifyMVar_ m io =
733   mask $ \restore -> do
734     a <- takeMVar m
735     a' <- catchAny (restore (io a))
736             (\e -> do putMVar m a; throw e)
737     putMVar m a'
738     return ()
739 \end{code}
740
741 %************************************************************************
742 %*                                                                      *
743 \subsection{Thread waiting}
744 %*                                                                      *
745 %************************************************************************
746
747 \begin{code}
748
749 -- Machinery needed to ensureb that we only have one copy of certain
750 -- CAFs in this module even when the base package is present twice, as
751 -- it is when base is dynamically loaded into GHCi.  The RTS keeps
752 -- track of the single true value of the CAF, so even when the CAFs in
753 -- the dynamically-loaded base package are reverted, nothing bad
754 -- happens.
755 --
756 sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
757 sharedCAF a get_or_set =
758    mask_ $ do
759      stable_ref <- newStablePtr a
760      let ref = castPtr (castStablePtrToPtr stable_ref)
761      ref2 <- get_or_set ref
762      if ref==ref2
763         then return a
764         else do freeStablePtr stable_ref
765                 deRefStablePtr (castPtrToStablePtr (castPtr ref2))
766
767 reportStackOverflow :: IO ()
768 reportStackOverflow = callStackOverflowHook
769
770 reportError :: SomeException -> IO ()
771 reportError ex = do
772    handler <- getUncaughtExceptionHandler
773    handler ex
774
775 -- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove
776 -- the unsafe below.
777 foreign import ccall unsafe "stackOverflow"
778         callStackOverflowHook :: IO ()
779
780 {-# NOINLINE uncaughtExceptionHandler #-}
781 uncaughtExceptionHandler :: IORef (SomeException -> IO ())
782 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
783    where
784       defaultHandler :: SomeException -> IO ()
785       defaultHandler se@(SomeException ex) = do
786          (hFlush stdout) `catchAny` (\ _ -> return ())
787          let msg = case cast ex of
788                Just Deadlock -> "no threads to run:  infinite loop or deadlock?"
789                _ -> case cast ex of
790                     Just (ErrorCall s) -> s
791                     _                  -> showsPrec 0 se ""
792          withCString "%s" $ \cfmt ->
793           withCString msg $ \cmsg ->
794             errorBelch cfmt cmsg
795
796 -- don't use errorBelch() directly, because we cannot call varargs functions
797 -- using the FFI.
798 foreign import ccall unsafe "HsBase.h errorBelch2"
799    errorBelch :: CString -> CString -> IO ()
800
801 setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
802 setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
803
804 getUncaughtExceptionHandler :: IO (SomeException -> IO ())
805 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
806
807 \end{code}