GHC/Conc/Sync.lhs

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