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