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 If the target of 'throwTo' is the calling thread, then the behaviour
 377 is the same as 'Control.Exception.throwIO', except that the exception
 378 is thrown as an asynchronous exception.  This means that if there is
 379 an enclosing pure computation, which would be the case if the current
 380 IO operation is inside 'unsafePerformIO' or 'unsafeInterleaveIO', that
 381 computation is not permanently replaced by the exception, but is
 382 suspended as if it had received an asynchronous exception.
 383
 384 Note that if 'throwTo' is called with the current thread as the
 385 target, the exception will be thrown even if the thread is currently
 386 inside 'mask' or 'uninterruptibleMask'.
 387   -}
 388 throwTo :: Exception e => ThreadId -> e -> IO ()
 389 throwTo (ThreadId tid) ex = IO $ \ s ->
 390    case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)
 391
 392 -- | Returns the 'ThreadId' of the calling thread (GHC only).
 393 myThreadId :: IO ThreadId
 394 myThreadId = IO $ \s ->
 395    case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)
 396
 397
 398 -- |The 'yield' action allows (forces, in a co-operative multitasking
 399 -- implementation) a context-switch to any other currently runnable
 400 -- threads (if any), and is occasionally useful when implementing
 401 -- concurrency abstractions.
 402 yield :: IO ()
 403 yield = IO $ \s ->
 404    case (yield# s) of s1 -> (# s1, () #)
 405
 406 {- | 'labelThread' stores a string as identifier for this thread if
 407 you built a RTS with debugging support. This identifier will be used in
 408 the debugging output to make distinction of different threads easier
 409 (otherwise you only have the thread state object\'s address in the heap).
 410
 411 Other applications like the graphical Concurrent Haskell Debugger
 412 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
 413 'labelThread' for their purposes as well.
 414 -}
 415
 416 labelThread :: ThreadId -> String -> IO ()
 417 labelThread (ThreadId t) str = IO $ \ s ->
 418    let !ps  = packCString# str
 419        !adr = byteArrayContents# ps in
 420      case (labelThread# t adr s) of s1 -> (# s1, () #)
 421
 422 --      Nota Bene: 'pseq' used to be 'seq'
 423 --                 but 'seq' is now defined in PrelGHC
 424 --
 425 -- "pseq" is defined a bit weirdly (see below)
 426 --
 427 -- The reason for the strange "lazy" call is that
 428 -- it fools the compiler into thinking that pseq  and par are non-strict in
 429 -- their second argument (even if it inlines pseq at the call site).
 430 -- If it thinks pseq is strict in "y", then it often evaluates
 431 -- "y" before "x", which is totally wrong.
 432
 433 {-# INLINE pseq  #-}
 434 pseq :: a -> b -> b
 435 pseq  x y = x `seq` lazy y
 436
 437 {-# INLINE par  #-}
 438 par :: a -> b -> b
 439 par  x y = case (par# x) of { _ -> lazy y }
 440
 441 -- | Internal function used by the RTS to run sparks.
 442 runSparks :: IO ()
 443 runSparks = IO loop
 444   where loop s = case getSpark# s of
 445                    (# s', n, p #) ->
 446                       if n ==# 0# then (# s', () #)
 447                                   else p `seq` loop s'
 448
 449 data BlockReason
 450   = BlockedOnMVar
 451         -- ^blocked on on 'MVar'
 452   | BlockedOnBlackHole
 453         -- ^blocked on a computation in progress by another thread
 454   | BlockedOnException
 455         -- ^blocked in 'throwTo'
 456   | BlockedOnSTM
 457         -- ^blocked in 'retry' in an STM transaction
 458   | BlockedOnForeignCall
 459         -- ^currently in a foreign call
 460   | BlockedOnOther
 461         -- ^blocked on some other resource.  Without @-threaded@,
 462         -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
 463         -- they show up as 'BlockedOnMVar'.
 464   deriving (Eq,Ord,Show)
 465
 466 -- | The current status of a thread
 467 data ThreadStatus
 468   = ThreadRunning
 469         -- ^the thread is currently runnable or running
 470   | ThreadFinished
 471         -- ^the thread has finished
 472   | ThreadBlocked  BlockReason
 473         -- ^the thread is blocked on some resource
 474   | ThreadDied
 475         -- ^the thread received an uncaught exception
 476   deriving (Eq,Ord,Show)
 477
 478 threadStatus :: ThreadId -> IO ThreadStatus
 479 threadStatus (ThreadId t) = IO $ \s ->
 480    case threadStatus# t s of
 481     (# s', stat, _cap, _locked #) -> (# s', mk_stat (I# stat) #)
 482    where
 483         -- NB. keep these in sync with includes/Constants.h
 484      mk_stat 0  = ThreadRunning
 485      mk_stat 1  = ThreadBlocked BlockedOnMVar
 486      mk_stat 2  = ThreadBlocked BlockedOnBlackHole
 487      mk_stat 6  = ThreadBlocked BlockedOnSTM
 488      mk_stat 10 = ThreadBlocked BlockedOnForeignCall
 489      mk_stat 11 = ThreadBlocked BlockedOnForeignCall
 490      mk_stat 12 = ThreadBlocked BlockedOnException
 491      mk_stat 16 = ThreadFinished
 492      mk_stat 17 = ThreadDied
 493      mk_stat _  = ThreadBlocked BlockedOnOther
 494
 495 -- | returns the number of the capability on which the thread is currently
 496 -- running, and a boolean indicating whether the thread is locked to
 497 -- that capability or not.  A thread is locked to a capability if it
 498 -- was created with @forkOn@.
 499 threadCapability :: ThreadId -> IO (Int, Bool)
 500 threadCapability (ThreadId t) = IO $ \s ->
 501    case threadStatus# t s of
 502      (# s', _, cap#, locked# #) -> (# s', (I# cap#, locked# /=# 0#) #)
 503 \end{code}
 504
 505
 506 %************************************************************************
 507 %*                                                                      *
 508 \subsection[stm]{Transactional heap operations}
 509 %*                                                                      *
 510 %************************************************************************
 511
 512 TVars are shared memory locations which support atomic memory
 513 transactions.
 514
 515 \begin{code}
 516 -- |A monad supporting atomic memory transactions.
 517 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
 518
 519 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
 520 unSTM (STM a) = a
 521
 522 INSTANCE_TYPEABLE1(STM,stmTc,"STM")
 523
 524 instance  Functor STM where
 525    fmap f x = x >>= (return . f)
 526
 527 instance  Monad STM  where
 528     {-# INLINE return #-}
 529     {-# INLINE (>>)   #-}
 530     {-# INLINE (>>=)  #-}
 531     m >> k      = thenSTM m k
 532     return x    = returnSTM x
 533     m >>= k     = bindSTM m k
 534
 535 bindSTM :: STM a -> (a -> STM b) -> STM b
 536 bindSTM (STM m) k = STM ( \s ->
 537   case m s of
 538     (# new_s, a #) -> unSTM (k a) new_s
 539   )
 540
 541 thenSTM :: STM a -> STM b -> STM b
 542 thenSTM (STM m) k = STM ( \s ->
 543   case m s of
 544     (# new_s, _ #) -> unSTM k new_s
 545   )
 546
 547 returnSTM :: a -> STM a
 548 returnSTM x = STM (\s -> (# s, x #))
 549
 550 instance MonadPlus STM where
 551   mzero = retry
 552   mplus = orElse
 553
 554 -- | Unsafely performs IO in the STM monad.  Beware: this is a highly
 555 -- dangerous thing to do.
 556 --
 557 --   * The STM implementation will often run transactions multiple
 558 --     times, so you need to be prepared for this if your IO has any
 559 --     side effects.
 560 --
 561 --   * The STM implementation will abort transactions that are known to
 562 --     be invalid and need to be restarted.  This may happen in the middle
 563 --     of `unsafeIOToSTM`, so make sure you don't acquire any resources
 564 --     that need releasing (exception handlers are ignored when aborting
 565 --     the transaction).  That includes doing any IO using Handles, for
 566 --     example.  Getting this wrong will probably lead to random deadlocks.
 567 --
 568 --   * The transaction may have seen an inconsistent view of memory when
 569 --     the IO runs.  Invariants that you expect to be true throughout
 570 --     your program may not be true inside a transaction, due to the
 571 --     way transactions are implemented.  Normally this wouldn't be visible
 572 --     to the programmer, but using `unsafeIOToSTM` can expose it.
 573 --
 574 unsafeIOToSTM :: IO a -> STM a
 575 unsafeIOToSTM (IO m) = STM m
 576
 577 -- |Perform a series of STM actions atomically.
 578 --
 579 -- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.
 580 -- Any attempt to do so will result in a runtime error.  (Reason: allowing
 581 -- this would effectively allow a transaction inside a transaction, depending
 582 -- on exactly when the thunk is evaluated.)
 583 --
 584 -- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',
 585 -- and which allows top-level TVars to be allocated.
 586
 587 atomically :: STM a -> IO a
 588 atomically (STM m) = IO (\s -> (atomically# m) s )
 589
 590 -- |Retry execution of the current memory transaction because it has seen
 591 -- values in TVars which mean that it should not continue (e.g. the TVars
 592 -- represent a shared buffer that is now empty).  The implementation may
 593 -- block the thread until one of the TVars that it has read from has been
 594 -- udpated. (GHC only)
 595 retry :: STM a
 596 retry = STM $ \s# -> retry# s#
 597
 598 -- |Compose two alternative STM actions (GHC only).  If the first action
 599 -- completes without retrying then it forms the result of the orElse.
 600 -- Otherwise, if the first action retries, then the second action is
 601 -- tried in its place.  If both actions retry then the orElse as a
 602 -- whole retries.
 603 orElse :: STM a -> STM a -> STM a
 604 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
 605
 606 -- | A variant of 'throw' that can only be used within the 'STM' monad.
 607 --
 608 -- Throwing an exception in @STM@ aborts the transaction and propagates the
 609 -- exception.
 610 --
 611 -- Although 'throwSTM' has a type that is an instance of the type of 'throw', the
 612 -- two functions are subtly different:
 613 --
 614 -- > throw e    `seq` x  ===> throw e
 615 -- > throwSTM e `seq` x  ===> x
 616 --
 617 -- The first example will cause the exception @e@ to be raised,
 618 -- whereas the second one won\'t.  In fact, 'throwSTM' will only cause
 619 -- an exception to be raised when it is used within the 'STM' monad.
 620 -- The 'throwSTM' variant should be used in preference to 'throw' to
 621 -- raise an exception within the 'STM' monad because it guarantees
 622 -- ordering with respect to other 'STM' operations, whereas 'throw'
 623 -- does not.
 624 throwSTM :: Exception e => e -> STM a
 625 throwSTM e = STM $ raiseIO# (toException e)
 626
 627 -- |Exception handling within STM actions.
 628 catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
 629 catchSTM (STM m) handler = STM $ catchSTM# m handler'
 630     where
 631       handler' e = case fromException e of
 632                      Just e' -> unSTM (handler e')
 633                      Nothing -> raiseIO# e
 634
 635 -- | Low-level primitive on which always and alwaysSucceeds are built.
 636 -- checkInv differs form these in that (i) the invariant is not
 637 -- checked when checkInv is called, only at the end of this and
 638 -- subsequent transcations, (ii) the invariant failure is indicated
 639 -- by raising an exception.
 640 checkInv :: STM a -> STM ()
 641 checkInv (STM m) = STM (\s -> (check# m) s)
 642
 643 -- | alwaysSucceeds adds a new invariant that must be true when passed
 644 -- to alwaysSucceeds, at the end of the current transaction, and at
 645 -- the end of every subsequent transaction.  If it fails at any
 646 -- of those points then the transaction violating it is aborted
 647 -- and the exception raised by the invariant is propagated.
 648 alwaysSucceeds :: STM a -> STM ()
 649 alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () )
 650                       checkInv i
 651
 652 -- | always is a variant of alwaysSucceeds in which the invariant is
 653 -- expressed as an STM Bool action that must return True.  Returning
 654 -- False or raising an exception are both treated as invariant failures.
 655 always :: STM Bool -> STM ()
 656 always i = alwaysSucceeds ( do v <- i
 657                                if (v) then return () else ( error "Transacional invariant violation" ) )
 658
 659 -- |Shared memory locations that support atomic memory transactions.
 660 data TVar a = TVar (TVar# RealWorld a)
 661
 662 INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")
 663
 664 instance Eq (TVar a) where
 665         (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
 666
 667 -- |Create a new TVar holding a value supplied
 668 newTVar :: a -> STM (TVar a)
 669 newTVar val = STM $ \s1# ->
 670     case newTVar# val s1# of
 671          (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
 672
 673 -- |@IO@ version of 'newTVar'.  This is useful for creating top-level
 674 -- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
 675 -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
 676 -- possible.
 677 newTVarIO :: a -> IO (TVar a)
 678 newTVarIO val = IO $ \s1# ->
 679     case newTVar# val s1# of
 680          (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
 681
 682 -- |Return the current value stored in a TVar.
 683 -- This is equivalent to
 684 --
 685 -- >  readTVarIO = atomically . readTVar
 686 --
 687 -- but works much faster, because it doesn't perform a complete
 688 -- transaction, it just reads the current value of the 'TVar'.
 689 readTVarIO :: TVar a -> IO a
 690 readTVarIO (TVar tvar#) = IO $ \s# -> readTVarIO# tvar# s#
 691
 692 -- |Return the current value stored in a TVar
 693 readTVar :: TVar a -> STM a
 694 readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
 695
 696 -- |Write the supplied value into a TVar
 697 writeTVar :: TVar a -> a -> STM ()
 698 writeTVar (TVar tvar#) val = STM $ \s1# ->
 699     case writeTVar# tvar# val s1# of
 700          s2# -> (# s2#, () #)
 701
 702 \end{code}
 703
 704 MVar utilities
 705
 706 \begin{code}
 707 withMVar :: MVar a -> (a -> IO b) -> IO b
 708 withMVar m io =
 709   mask $ \restore -> do
 710     a <- takeMVar m
 711     b <- catchAny (restore (io a))
 712             (\e -> do putMVar m a; throw e)
 713     putMVar m a
 714     return b
 715
 716 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
 717 modifyMVar_ m io =
 718   mask $ \restore -> do
 719     a <- takeMVar m
 720     a' <- catchAny (restore (io a))
 721             (\e -> do putMVar m a; throw e)
 722     putMVar m a'
 723     return ()
 724 \end{code}
 725
 726 %************************************************************************
 727 %*                                                                      *
 728 \subsection{Thread waiting}
 729 %*                                                                      *
 730 %************************************************************************
 731
 732 \begin{code}
 733
 734 -- Machinery needed to ensureb that we only have one copy of certain
 735 -- CAFs in this module even when the base package is present twice, as
 736 -- it is when base is dynamically loaded into GHCi.  The RTS keeps
 737 -- track of the single true value of the CAF, so even when the CAFs in
 738 -- the dynamically-loaded base package are reverted, nothing bad
 739 -- happens.
 740 --
 741 sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a
 742 sharedCAF a get_or_set =
 743    mask_ $ do
 744      stable_ref <- newStablePtr a
 745      let ref = castPtr (castStablePtrToPtr stable_ref)
 746      ref2 <- get_or_set ref
 747      if ref==ref2
 748         then return a
 749         else do freeStablePtr stable_ref
 750                 deRefStablePtr (castPtrToStablePtr (castPtr ref2))
 751
 752 reportStackOverflow :: IO ()
 753 reportStackOverflow = callStackOverflowHook
 754
 755 reportError :: SomeException -> IO ()
 756 reportError ex = do
 757    handler <- getUncaughtExceptionHandler
 758    handler ex
 759
 760 -- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove
 761 -- the unsafe below.
 762 foreign import ccall unsafe "stackOverflow"
 763         callStackOverflowHook :: IO ()
 764
 765 {-# NOINLINE uncaughtExceptionHandler #-}
 766 uncaughtExceptionHandler :: IORef (SomeException -> IO ())
 767 uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
 768    where
 769       defaultHandler :: SomeException -> IO ()
 770       defaultHandler se@(SomeException ex) = do
 771          (hFlush stdout) `catchAny` (\ _ -> return ())
 772          let msg = case cast ex of
 773                Just Deadlock -> "no threads to run:  infinite loop or deadlock?"
 774                _ -> case cast ex of
 775                     Just (ErrorCall s) -> s
 776                     _                  -> showsPrec 0 se ""
 777          withCString "%s" $ \cfmt ->
 778           withCString msg $ \cmsg ->
 779             errorBelch cfmt cmsg
 780
 781 -- don't use errorBelch() directly, because we cannot call varargs functions
 782 -- using the FFI.
 783 foreign import ccall unsafe "HsBase.h errorBelch2"
 784    errorBelch :: CString -> CString -> IO ()
 785
 786 setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO ()
 787 setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
 788
 789 getUncaughtExceptionHandler :: IO (SomeException -> IO ())
 790 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
 791
 792 \end{code}