GHC/Conc/Sync.lhs

   1 \begin{code}
   2 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
   3 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
   4 {-# OPTIONS_HADDOCK not-home #-}
   5 -----------------------------------------------------------------------------
   6 -- |
   7 -- Module      :  GHC.Conc.Sync
   8 -- Copyright   :  (c) The University of Glasgow, 1994-2002
   9 -- License     :  see libraries/base/LICENSE
  10 --
  11 -- Maintainer  :  cvs-ghc@haskell.org
  12 -- Stability   :  internal
  13 -- Portability :  non-portable (GHC extensions)
  14 --
  15 -- Basic concurrency stuff.
  16 --
  17 -----------------------------------------------------------------------------
  18
  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:
  23
  24 #include "Typeable.h"
  25
  26 -- #not-home
  27 module GHC.Conc.Sync
  28         ( ThreadId(..)
  29
  30         -- * Forking and suchlike
  31         , forkIO        -- :: IO a -> IO ThreadId
  32         , forkIOUnmasked
  33         , forkOnIO      -- :: Int -> IO a -> IO ThreadId
  34         , forkOnIOUnmasked
  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
  43         , runSparks
  44         , yield         -- :: IO ()
  45         , labelThread   -- :: ThreadId -> String -> IO ()
  46
  47         , ThreadStatus(..), BlockReason(..)
  48         , threadStatus  -- :: ThreadId -> IO ThreadStatus
  49
  50         -- * TVars
  51         , STM(..)
  52         , atomically    -- :: STM a -> IO a
  53         , retry         -- :: STM 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 ()
  59         , TVar(..)
  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
  66
  67         -- * Miscellaneous
  68         , withMVar
  69         , modifyMVar_
  70
  71         , setUncaughtExceptionHandler      -- :: (Exception -> IO ()) -> IO ()
  72         , getUncaughtExceptionHandler      -- :: IO (Exception -> IO ())
  73
  74         , reportError, reportStackOverflow
  75
  76         , sharedCAF
  77         ) where
  78
  79 import Foreign hiding (unsafePerformIO)
  80 import Foreign.C
  81
  82 #ifdef mingw32_HOST_OS
  83 import Data.Typeable
  84 #endif
  85
  86 #ifndef mingw32_HOST_OS
  87 import Data.Dynamic
  88 #endif
  89 import Control.Monad
  90 import Data.Maybe
  91
  92 import GHC.Base
  93 import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
  94 import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout )
  95 import GHC.IO
  96 import GHC.IO.Exception
  97 import GHC.Exception
  98 import GHC.IORef
  99 import GHC.MVar
 100 import GHC.Real         ( fromIntegral )
 101 import GHC.Pack         ( packCString# )
 102 import GHC.Show         ( Show(..), showString )
 103
 104 infixr 0 `par`, `pseq`
 105 \end{code}
 106
 107 %************************************************************************
 108 %*                                                                      *
 109 \subsection{@ThreadId@, @par@, and @fork@}
 110 %*                                                                      *
 111 %************************************************************************
 112
 113 \begin{code}
 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
 117 -- type variables.
 118 {- ^
 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
 125 program.
 126
 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.
 131
 132 /Note/: Hugs does not provide any operations on other threads;
 133 it defines 'ThreadId' as a synonym for ().
 134 -}
 135
 136 instance Show ThreadId where
 137    showsPrec d t =
 138         showString "ThreadId " .
 139         showsPrec d (getThreadId (id2TSO t))
 140
 141 foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
 142
 143 id2TSO :: ThreadId -> ThreadId#
 144 id2TSO (ThreadId t) = t
 145
 146 foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
 147 -- Returns -1, 0, 1
 148
 149 cmpThread :: ThreadId -> ThreadId -> Ordering
 150 cmpThread t1 t2 =
 151    case cmp_thread (id2TSO t1) (id2TSO t2) of
 152       -1 -> LT
 153       0  -> EQ
 154       _  -> GT -- must be 1
 155
 156 instance Eq ThreadId where
 157    t1 == t2 =
 158       case t1 `cmpThread` t2 of
 159          EQ -> True
 160          _  -> False
 161
 162 instance Ord ThreadId where
 163    compare = cmpThread
 164
 165 {- |
 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
 168 thread.
 169
 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.
 172
 173 GHC note: the new thread inherits the /masked/ state of the parent
 174 (see 'Control.Exception.mask').
 175
 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').
 180 -}
 181 forkIO :: IO () -> IO ThreadId
 182 forkIO action = IO $ \ s ->
 183    case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
 184  where
 185   action_plus = catchException action childHandler
 186
 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)
 191
 192 {- |
 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.
 199
 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
 203 equivalent).
 204 -}
 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 #)
 208  where
 209   action_plus = catchException action childHandler
 210
 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)
 215
 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
 219 -- the machine.
 220 numCapabilities :: Int
 221 numCapabilities = unsafePerformIO $  do
 222                     n <- peek n_capabilities
 223                     return (fromIntegral n)
 224
 225 -- | Returns the number of sparks currently in the local spark pool
 226 numSparks :: IO Int
 227 numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #)
 228
 229 #if defined(mingw32_HOST_OS) && defined(__PIC__)
 230 foreign import ccall "_imp__n_capabilities" n_capabilities :: Ptr CInt
 231 #else
 232 foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt
 233 #endif
 234 childHandler :: SomeException -> IO ()
 235 childHandler err = catchException (real_handler err) childHandler
 236
 237 real_handler :: SomeException -> IO ()
 238 real_handler se@(SomeException ex) =
 239   -- ignore thread GC and killThread exceptions:
 240   case cast ex of
 241   Just BlockedIndefinitelyOnMVar        -> return ()
 242   _ -> case cast ex of
 243        Just BlockedIndefinitelyOnSTM    -> return ()
 244        _ -> case cast ex of
 245             Just ThreadKilled           -> return ()
 246             _ -> case cast ex of
 247                  -- report all others:
 248                  Just StackOverflow     -> reportStackOverflow
 249                  _                      -> reportError se
 250
 251 {- | 'killThread' raises the 'ThreadKilled' exception in the given
 252 thread (GHC only).
 253
 254 > killThread tid = throwTo tid ThreadKilled
 255
 256 -}
 257 killThread :: ThreadId -> IO ()
 258 killThread tid = throwTo tid ThreadKilled
 259
 260 {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
 261
 262 'throwTo' does not return until the exception has been raised in the
 263 target thread.
 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.
 269
 270 Whatever work the target thread was doing when the exception was
 271 raised is not lost: the computation is suspended until required by
 272 another thread.
 273
 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.
 281
 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.
 291
 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'.
 298
 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.
 301
 302   -}
 303 throwTo :: Exception e => ThreadId -> e -> IO ()
 304 throwTo (ThreadId tid) ex = IO $ \ s ->
 305    case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)
 306
 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 #)
 311
 312
 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.
 317 yield :: IO ()
 318 yield = IO $ \s ->
 319    case (yield# s) of s1 -> (# s1, () #)
 320
 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).
 325
 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.
 329 -}
 330
 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, () #)
 336
 337 --      Nota Bene: 'pseq' used to be 'seq'
 338 --                 but 'seq' is now defined in PrelGHC
 339 --
 340 -- "pseq" is defined a bit weirdly (see below)
 341 --
 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.
 347
 348 {-# INLINE pseq  #-}
 349 pseq :: a -> b -> b
 350 pseq  x y = x `seq` lazy y
 351
 352 {-# INLINE par  #-}
 353 par :: a -> b -> b
 354 par  x y = case (par# x) of { _ -> lazy y }
 355
 356 -- | Internal function used by the RTS to run sparks.
 357 runSparks :: IO ()
 358 runSparks = IO loop
 359   where loop s = case getSpark# s of
 360                    (# s', n, p #) ->
 361                       if n ==# 0# then (# s', () #)
 362                                   else p `seq` loop s'
 363
 364 data BlockReason
 365   = BlockedOnMVar
 366         -- ^blocked on on 'MVar'
 367   | BlockedOnBlackHole
 368         -- ^blocked on a computation in progress by another thread
 369   | BlockedOnException
 370         -- ^blocked in 'throwTo'
 371   | BlockedOnSTM
 372         -- ^blocked in 'retry' in an STM transaction
 373   | BlockedOnForeignCall
 374         -- ^currently in a foreign call
 375   | BlockedOnOther
 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)
 380
 381 -- | The current status of a thread
 382 data ThreadStatus
 383   = ThreadRunning
 384         -- ^the thread is currently runnable or running
 385   | ThreadFinished
 386         -- ^the thread has finished
 387   | ThreadBlocked  BlockReason
 388         -- ^the thread is blocked on some resource
 389   | ThreadDied
 390         -- ^the thread received an uncaught exception
 391   deriving (Eq,Ord,Show)
 392
 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) #)
 397    where
 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
 409 \end{code}
 410
 411
 412 %************************************************************************
 413 %*                                                                      *
 414 \subsection[stm]{Transactional heap operations}
 415 %*                                                                      *
 416 %************************************************************************
 417
 418 TVars are shared memory locations which support atomic memory
 419 transactions.
 420
 421 \begin{code}
 422 -- |A monad supporting atomic memory transactions.
 423 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
 424
 425 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
 426 unSTM (STM a) = a
 427
 428 INSTANCE_TYPEABLE1(STM,stmTc,"STM")
 429
 430 instance  Functor STM where
 431    fmap f x = x >>= (return . f)
 432
 433 instance  Monad STM  where
 434     {-# INLINE return #-}
 435     {-# INLINE (>>)   #-}
 436     {-# INLINE (>>=)  #-}
 437     m >> k      = thenSTM m k
 438     return x    = returnSTM x
 439     m >>= k     = bindSTM m k
 440
 441 bindSTM :: STM a -> (a -> STM b) -> STM b
 442 bindSTM (STM m) k = STM ( \s ->
 443   case m s of
 444     (# new_s, a #) -> unSTM (k a) new_s
 445   )
 446
 447 thenSTM :: STM a -> STM b -> STM b
 448 thenSTM (STM m) k = STM ( \s ->
 449   case m s of
 450     (# new_s, _ #) -> unSTM k new_s
 451   )
 452
 453 returnSTM :: a -> STM a
 454 returnSTM x = STM (\s -> (# s, x #))
 455
 456 instance MonadPlus STM where
 457   mzero = retry
 458   mplus = orElse
 459
 460 -- | Unsafely performs IO in the STM monad.  Beware: this is a highly
 461 -- dangerous thing to do.
 462 --
 463 --   * The STM implementation will often run transactions multiple
 464 --     times, so you need to be prepared for this if your IO has any
 465 --     side effects.
 466 --
 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.
 473 --
 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.
 479 --
 480 unsafeIOToSTM :: IO a -> STM a
 481 unsafeIOToSTM (IO m) = STM m
 482
 483 -- |Perform a series of STM actions atomically.
 484 --
 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.)
 489 --
 490 -- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',
 491 -- and which allows top-level TVars to be allocated.
 492
 493 atomically :: STM a -> IO a
 494 atomically (STM m) = IO (\s -> (atomically# m) s )
 495
 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)
 501 retry :: STM a
 502 retry = STM $ \s# -> retry# s#
 503
 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
 508 -- whole retries.
 509 orElse :: STM a -> STM a -> STM a
 510 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
 511
 512 -- | A variant of 'throw' that can only be used within the 'STM' monad.
 513 --
 514 -- Throwing an exception in @STM@ aborts the transaction and propagates the
 515 -- exception.
 516 --
 517 -- Although 'throwSTM' has a type that is an instance of the type of 'throw', the
 518 -- two functions are subtly different:
 519 --
 520 -- > throw e    `seq` x  ===> throw e
 521 -- > throwSTM e `seq` x  ===> x
 522 --
 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'
 529 -- does not.
 530 throwSTM :: Exception e => e -> STM a
 531 throwSTM e = STM $ raiseIO# (toException e)
 532
 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'
 536     where
 537       handler' e = case fromException e of
 538                      Just e' -> unSTM (handler e')
 539                      Nothing -> raiseIO# e
 540
 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)
 548
 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 () )
 556                       checkInv i
 557
 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" ) )
 564
 565 -- |Shared memory locations that support atomic memory transactions.
 566 data TVar a = TVar (TVar# RealWorld a)
 567
 568 INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")
 569
 570 instance Eq (TVar a) where
 571         (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
 572
 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# #)
 578
 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
 582 -- possible.
 583 newTVarIO :: a -> IO (TVar a)
 584 newTVarIO val = IO $ \s1# ->
 585     case newTVar# val s1# of
 586          (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
 587
 588 -- |Return the current value stored in a TVar.
 589 -- This is equivalent to
 590 --
 591 -- >  readTVarIO = atomically . readTVar
 592 --
 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#
 597
 598 -- |Return the current value stored in a TVar
 599 readTVar :: TVar a -> STM a
 600 readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
 601
 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
 606          s2# -> (# s2#, () #)
 607
 608 \end{code}
 609
 610 MVar utilities
 611
 612 \begin{code}
 613 withMVar :: MVar a -> (a -> IO b) -> IO b
 614 withMVar m io =
 615   mask $ \restore -> do
 616     a <- takeMVar m
 617     b <- catchAny (restore (io a))
 618             (\e -> do putMVar m a; throw e)
 619     putMVar m a
 620     return b
 621
 622 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
 623 modifyMVar_ m io =
 624   mask $ \restore -> do
 625     a <- takeMVar m
 626     a' <- catchAny (restore (io a))
 627             (\e -> do putMVar m a; throw e)
 628     putMVar m a'
 629     return ()
 630 \end{code}
 631
 632 %************************************************************************
 633 %*                                                                      *
 634 \subsection{Thread waiting}
 635 %*                                                                      *
 636 %************************************************************************
 637
 638 \begin{code}
 639
 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
 645 -- happens.
 646 --
 647 sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
 648 sharedCAF a get_or_set =
 649    mask_ $ do
 650      stable_ref <- newStablePtr a
 651      let ref = castPtr (castStablePtrToPtr stable_ref)
 652      ref2 <- get_or_set ref
 653      if ref==ref2
 654         then return a
 655         else do freeStablePtr stable_ref
 656                 deRefStablePtr (castPtrToStablePtr (castPtr ref2))
 657
 658 reportStackOverflow :: IO ()
 659 reportStackOverflow = callStackOverflowHook
 660
 661 reportError :: SomeException -> IO ()
 662 reportError ex = do
 663    handler <- getUncaughtExceptionHandler
 664    handler ex
 665
 666 -- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove
 667 -- the unsafe below.
 668 foreign import ccall unsafe "stackOverflow"
 669         callStackOverflowHook :: IO ()
 670
 671 {-# NOINLINE uncaughtExceptionHandler #-}
 672 uncaughtExceptionHandler :: IORef (SomeException -> IO ())
 673 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
 674    where
 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?"
 680                _ -> case cast ex of
 681                     Just (ErrorCall s) -> s
 682                     _                  -> showsPrec 0 se ""
 683          withCString "%s" $ \cfmt ->
 684           withCString msg $ \cmsg ->
 685             errorBelch cfmt cmsg
 686
 687 -- don't use errorBelch() directly, because we cannot call varargs functions
 688 -- using the FFI.
 689 foreign import ccall unsafe "HsBase.h errorBelch2"
 690    errorBelch :: CString -> CString -> IO ()
 691
 692 setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
 693 setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
 694
 695 getUncaughtExceptionHandler :: IO (SomeException -> IO ())
 696 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
 697
 698 \end{code}