GHC/Conc/Sync.lhs

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