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