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