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