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