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