GHC/Conc.lhs

   1 \begin{code}
   2 {-# OPTIONS_GHC -fno-implicit-prelude #-}
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  GHC.Conc
   6 -- Copyright   :  (c) The University of Glasgow, 1994-2002
   7 -- License     :  see libraries/base/LICENSE
   8 --
   9 -- Maintainer  :  cvs-ghc@haskell.org
  10 -- Stability   :  internal
  11 -- Portability :  non-portable (GHC extensions)
  12 --
  13 -- Basic concurrency stuff.
  14 --
  15 -----------------------------------------------------------------------------
  16
  17 -- No: #hide, because bits of this module are exposed by the stm package.
  18 -- However, we don't want this module to be the home location for the
  19 -- bits it exports, we'd rather have Control.Concurrent and the other
  20 -- higher level modules be the home.  Hence:
  21
  22 #include "Typeable.h"
  23
  24 -- #not-home
  25 module GHC.Conc
  26         ( ThreadId(..)
  27
  28         -- * Forking and suchlike
  29         , forkIO        -- :: IO a -> IO ThreadId
  30         , forkOnIO      -- :: Int -> IO a -> IO ThreadId
  31         , numCapabilities -- :: Int
  32         , childHandler  -- :: Exception -> IO ()
  33         , myThreadId    -- :: IO ThreadId
  34         , killThread    -- :: ThreadId -> IO ()
  35         , throwTo       -- :: ThreadId -> Exception -> IO ()
  36         , par           -- :: a -> b -> b
  37         , pseq          -- :: a -> b -> b
  38         , yield         -- :: IO ()
  39         , labelThread   -- :: ThreadId -> String -> IO ()
  40
  41         -- * Waiting
  42         , threadDelay           -- :: Int -> IO ()
  43         , registerDelay         -- :: Int -> IO (TVar Bool)
  44         , threadWaitRead        -- :: Int -> IO ()
  45         , threadWaitWrite       -- :: Int -> IO ()
  46
  47         -- * MVars
  48         , MVar          -- abstract
  49         , newMVar       -- :: a -> IO (MVar a)
  50         , newEmptyMVar  -- :: IO (MVar a)
  51         , takeMVar      -- :: MVar a -> IO a
  52         , putMVar       -- :: MVar a -> a -> IO ()
  53         , tryTakeMVar   -- :: MVar a -> IO (Maybe a)
  54         , tryPutMVar    -- :: MVar a -> a -> IO Bool
  55         , isEmptyMVar   -- :: MVar a -> IO Bool
  56         , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
  57
  58         -- * TVars
  59         , STM           -- abstract
  60         , atomically    -- :: STM a -> IO a
  61         , retry         -- :: STM a
  62         , orElse        -- :: STM a -> STM a -> STM a
  63         , catchSTM      -- :: STM a -> (Exception -> STM a) -> STM a
  64         , alwaysSucceeds -- :: STM a -> STM ()
  65         , always        -- :: STM Bool -> STM ()
  66         , TVar          -- abstract
  67         , newTVar       -- :: a -> STM (TVar a)
  68         , newTVarIO     -- :: a -> STM (TVar a)
  69         , readTVar      -- :: TVar a -> STM a
  70         , writeTVar     -- :: a -> TVar a -> STM ()
  71         , unsafeIOToSTM -- :: IO a -> STM a
  72
  73         -- * Miscellaneous
  74 #ifdef mingw32_HOST_OS
  75         , asyncRead     -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
  76         , asyncWrite    -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
  77         , asyncDoProc   -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
  78
  79         , asyncReadBA   -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
  80         , asyncWriteBA  -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
  81 #endif
  82
  83 #ifndef mingw32_HOST_OS
  84         , signalHandlerLock
  85 #endif
  86
  87         , ensureIOManagerIsRunning
  88         ) where
  89
  90 import System.Posix.Types
  91 #ifndef mingw32_HOST_OS
  92 import System.Posix.Internals
  93 #endif
  94 import Foreign
  95 import Foreign.C
  96
  97 #ifndef __HADDOCK__
  98 import {-# SOURCE #-} GHC.TopHandler ( reportError, reportStackOverflow )
  99 #endif
 100
 101 import Data.Maybe
 102
 103 import GHC.Base
 104 import GHC.IOBase
 105 import GHC.Num          ( Num(..) )
 106 import GHC.Real         ( fromIntegral, div )
 107 #ifndef mingw32_HOST_OS
 108 import GHC.Base         ( Int(..) )
 109 #endif
 110 import GHC.Exception
 111 import GHC.Pack         ( packCString# )
 112 import GHC.Ptr          ( Ptr(..), plusPtr, FunPtr(..) )
 113 import GHC.STRef
 114 import GHC.Show         ( Show(..), showString )
 115 import Data.Typeable
 116
 117 infixr 0 `par`, `pseq`
 118 \end{code}
 119
 120 %************************************************************************
 121 %*                                                                      *
 122 \subsection{@ThreadId@, @par@, and @fork@}
 123 %*                                                                      *
 124 %************************************************************************
 125
 126 \begin{code}
 127 data ThreadId = ThreadId ThreadId# deriving( Typeable )
 128 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
 129 -- But since ThreadId# is unlifted, the Weak type must use open
 130 -- type variables.
 131 {- ^
 132 A 'ThreadId' is an abstract type representing a handle to a thread.
 133 'ThreadId' is an instance of 'Eq', 'Ord' and 'Show', where
 134 the 'Ord' instance implements an arbitrary total ordering over
 135 'ThreadId's. The 'Show' instance lets you convert an arbitrary-valued
 136 'ThreadId' to string form; showing a 'ThreadId' value is occasionally
 137 useful when debugging or diagnosing the behaviour of a concurrent
 138 program.
 139
 140 /Note/: in GHC, if you have a 'ThreadId', you essentially have
 141 a pointer to the thread itself.  This means the thread itself can\'t be
 142 garbage collected until you drop the 'ThreadId'.
 143 This misfeature will hopefully be corrected at a later date.
 144
 145 /Note/: Hugs does not provide any operations on other threads;
 146 it defines 'ThreadId' as a synonym for ().
 147 -}
 148
 149 instance Show ThreadId where
 150    showsPrec d t =
 151         showString "ThreadId " .
 152         showsPrec d (getThreadId (id2TSO t))
 153
 154 foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
 155
 156 id2TSO :: ThreadId -> ThreadId#
 157 id2TSO (ThreadId t) = t
 158
 159 foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
 160 -- Returns -1, 0, 1
 161
 162 cmpThread :: ThreadId -> ThreadId -> Ordering
 163 cmpThread t1 t2 =
 164    case cmp_thread (id2TSO t1) (id2TSO t2) of
 165       -1 -> LT
 166       0  -> EQ
 167       _  -> GT -- must be 1
 168
 169 instance Eq ThreadId where
 170    t1 == t2 =
 171       case t1 `cmpThread` t2 of
 172          EQ -> True
 173          _  -> False
 174
 175 instance Ord ThreadId where
 176    compare = cmpThread
 177
 178 {- |
 179 This sparks off a new thread to run the 'IO' computation passed as the
 180 first argument, and returns the 'ThreadId' of the newly created
 181 thread.
 182
 183 The new thread will be a lightweight thread; if you want to use a foreign
 184 library that uses thread-local storage, use 'forkOS' instead.
 185 -}
 186 forkIO :: IO () -> IO ThreadId
 187 forkIO action = IO $ \ s ->
 188    case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
 189  where
 190   action_plus = catchException action childHandler
 191
 192 forkOnIO :: Int -> IO () -> IO ThreadId
 193 forkOnIO (I# cpu) action = IO $ \ s ->
 194    case (forkOn# cpu action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
 195  where
 196   action_plus = catchException action childHandler
 197
 198 -- | the value passed to the @+RTS -N@ flag.  This is the number of
 199 -- Haskell threads that can run truly simultaneously at any given
 200 -- time, and is typically set to the number of physical CPU cores on
 201 -- the machine.
 202 numCapabilities :: Int
 203 numCapabilities = unsafePerformIO $  do
 204                     n <- peek n_capabilities
 205                     return (fromIntegral n)
 206
 207 foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt
 208
 209 childHandler :: Exception -> IO ()
 210 childHandler err = catchException (real_handler err) childHandler
 211
 212 real_handler :: Exception -> IO ()
 213 real_handler ex =
 214   case ex of
 215         -- ignore thread GC and killThread exceptions:
 216         BlockedOnDeadMVar            -> return ()
 217         BlockedIndefinitely          -> return ()
 218         AsyncException ThreadKilled  -> return ()
 219
 220         -- report all others:
 221         AsyncException StackOverflow -> reportStackOverflow
 222         other       -> reportError other
 223
 224 {- | 'killThread' terminates the given thread (GHC only).
 225 Any work already done by the thread isn\'t
 226 lost: the computation is suspended until required by another thread.
 227 The memory used by the thread will be garbage collected if it isn\'t
 228 referenced from anywhere.  The 'killThread' function is defined in
 229 terms of 'throwTo':
 230
 231 > killThread tid = throwTo tid (AsyncException ThreadKilled)
 232
 233 -}
 234 killThread :: ThreadId -> IO ()
 235 killThread tid = throwTo tid (AsyncException ThreadKilled)
 236
 237 {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
 238
 239 'throwTo' does not return until the exception has been raised in the
 240 target thread.
 241 The calling thread can thus be certain that the target
 242 thread has received the exception.  This is a useful property to know
 243 when dealing with race conditions: eg. if there are two threads that
 244 can kill each other, it is guaranteed that only one of the threads
 245 will get to kill the other.
 246
 247 If the target thread is currently making a foreign call, then the
 248 exception will not be raised (and hence 'throwTo' will not return)
 249 until the call has completed.  This is the case regardless of whether
 250 the call is inside a 'block' or not.
 251
 252 Important note: the behaviour of 'throwTo' differs from that described in
 253 the paper \"Asynchronous exceptions in Haskell\"
 254 (<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>).
 255 In the paper, 'throwTo' is non-blocking; but the library implementation adopts
 256 a more synchronous design in which 'throwTo' does not return until the exception
 257 is received by the target thread.  The trade-off is discussed in Section 8 of the paper.
 258 Like any blocking operation, 'throwTo' is therefore interruptible (see Section 4.3 of
 259 the paper).
 260
 261 There is currently no guarantee that the exception delivered by 'throwTo' will be
 262 delivered at the first possible opportunity.  In particular, if a thread may
 263 unblock and then re-block exceptions (using 'unblock' and 'block') without receiving
 264 a pending 'throwTo'.  This is arguably undesirable behaviour.
 265
 266  -}
 267 throwTo :: ThreadId -> Exception -> IO ()
 268 throwTo (ThreadId id) ex = IO $ \ s ->
 269    case (killThread# id ex s) of s1 -> (# s1, () #)
 270
 271 -- | Returns the 'ThreadId' of the calling thread (GHC only).
 272 myThreadId :: IO ThreadId
 273 myThreadId = IO $ \s ->
 274    case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
 275
 276
 277 -- |The 'yield' action allows (forces, in a co-operative multitasking
 278 -- implementation) a context-switch to any other currently runnable
 279 -- threads (if any), and is occasionally useful when implementing
 280 -- concurrency abstractions.
 281 yield :: IO ()
 282 yield = IO $ \s ->
 283    case (yield# s) of s1 -> (# s1, () #)
 284
 285 {- | 'labelThread' stores a string as identifier for this thread if
 286 you built a RTS with debugging support. This identifier will be used in
 287 the debugging output to make distinction of different threads easier
 288 (otherwise you only have the thread state object\'s address in the heap).
 289
 290 Other applications like the graphical Concurrent Haskell Debugger
 291 (<http://www.informatik.uni-kiel.de/~fhu/chd/>) may choose to overload
 292 'labelThread' for their purposes as well.
 293 -}
 294
 295 labelThread :: ThreadId -> String -> IO ()
 296 labelThread (ThreadId t) str = IO $ \ s ->
 297    let ps  = packCString# str
 298        adr = byteArrayContents# ps in
 299      case (labelThread# t adr s) of s1 -> (# s1, () #)
 300
 301 --      Nota Bene: 'pseq' used to be 'seq'
 302 --                 but 'seq' is now defined in PrelGHC
 303 --
 304 -- "pseq" is defined a bit weirdly (see below)
 305 --
 306 -- The reason for the strange "lazy" call is that
 307 -- it fools the compiler into thinking that pseq  and par are non-strict in
 308 -- their second argument (even if it inlines pseq at the call site).
 309 -- If it thinks pseq is strict in "y", then it often evaluates
 310 -- "y" before "x", which is totally wrong.
 311
 312 {-# INLINE pseq  #-}
 313 pseq :: a -> b -> b
 314 pseq  x y = x `seq` lazy y
 315
 316 {-# INLINE par  #-}
 317 par :: a -> b -> b
 318 par  x y = case (par# x) of { _ -> lazy y }
 319 \end{code}
 320
 321
 322 %************************************************************************
 323 %*                                                                      *
 324 \subsection[stm]{Transactional heap operations}
 325 %*                                                                      *
 326 %************************************************************************
 327
 328 TVars are shared memory locations which support atomic memory
 329 transactions.
 330
 331 \begin{code}
 332 -- |A monad supporting atomic memory transactions.
 333 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
 334
 335 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
 336 unSTM (STM a) = a
 337
 338 INSTANCE_TYPEABLE1(STM,stmTc,"STM")
 339
 340 instance  Functor STM where
 341    fmap f x = x >>= (return . f)
 342
 343 instance  Monad STM  where
 344     {-# INLINE return #-}
 345     {-# INLINE (>>)   #-}
 346     {-# INLINE (>>=)  #-}
 347     m >> k      = thenSTM m k
 348     return x    = returnSTM x
 349     m >>= k     = bindSTM m k
 350
 351 bindSTM :: STM a -> (a -> STM b) -> STM b
 352 bindSTM (STM m) k = STM ( \s ->
 353   case m s of
 354     (# new_s, a #) -> unSTM (k a) new_s
 355   )
 356
 357 thenSTM :: STM a -> STM b -> STM b
 358 thenSTM (STM m) k = STM ( \s ->
 359   case m s of
 360     (# new_s, a #) -> unSTM k new_s
 361   )
 362
 363 returnSTM :: a -> STM a
 364 returnSTM x = STM (\s -> (# s, x #))
 365
 366 -- | Unsafely performs IO in the STM monad.
 367 unsafeIOToSTM :: IO a -> STM a
 368 unsafeIOToSTM (IO m) = STM m
 369
 370 -- |Perform a series of STM actions atomically.
 371 --
 372 -- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'.
 373 -- Any attempt to do so will result in a runtime error.  (Reason: allowing
 374 -- this would effectively allow a transaction inside a transaction, depending
 375 -- on exactly when the thunk is evaluated.)
 376 --
 377 -- However, see 'newTVarIO', which can be called inside 'unsafePerformIO',
 378 -- and which allows top-level TVars to be allocated.
 379
 380 atomically :: STM a -> IO a
 381 atomically (STM m) = IO (\s -> (atomically# m) s )
 382
 383 -- |Retry execution of the current memory transaction because it has seen
 384 -- values in TVars which mean that it should not continue (e.g. the TVars
 385 -- represent a shared buffer that is now empty).  The implementation may
 386 -- block the thread until one of the TVars that it has read from has been
 387 -- udpated. (GHC only)
 388 retry :: STM a
 389 retry = STM $ \s# -> retry# s#
 390
 391 -- |Compose two alternative STM actions (GHC only).  If the first action
 392 -- completes without retrying then it forms the result of the orElse.
 393 -- Otherwise, if the first action retries, then the second action is
 394 -- tried in its place.  If both actions retry then the orElse as a
 395 -- whole retries.
 396 orElse :: STM a -> STM a -> STM a
 397 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
 398
 399 -- |Exception handling within STM actions.
 400 catchSTM :: STM a -> (Exception -> STM a) -> STM a
 401 catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s
 402
 403 -- | Low-level primitive on which always and alwaysSucceeds are built.
 404 -- checkInv differs form these in that (i) the invariant is not
 405 -- checked when checkInv is called, only at the end of this and
 406 -- subsequent transcations, (ii) the invariant failure is indicated
 407 -- by raising an exception.
 408 checkInv :: STM a -> STM ()
 409 checkInv (STM m) = STM (\s -> (check# m) s)
 410
 411 -- | alwaysSucceeds adds a new invariant that must be true when passed
 412 -- to alwaysSucceeds, at the end of the current transaction, and at
 413 -- the end of every subsequent transaction.  If it fails at any
 414 -- of those points then the transaction violating it is aborted
 415 -- and the exception raised by the invariant is propagated.
 416 alwaysSucceeds :: STM a -> STM ()
 417 alwaysSucceeds i = do ( do i ; retry ) `orElse` ( return () )
 418                       checkInv i
 419
 420 -- | always is a variant of alwaysSucceeds in which the invariant is
 421 -- expressed as an STM Bool action that must return True.  Returning
 422 -- False or raising an exception are both treated as invariant failures.
 423 always :: STM Bool -> STM ()
 424 always i = alwaysSucceeds ( do v <- i
 425                                if (v) then return () else ( error "Transacional invariant violation" ) )
 426
 427 -- |Shared memory locations that support atomic memory transactions.
 428 data TVar a = TVar (TVar# RealWorld a)
 429
 430 INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")
 431
 432 instance Eq (TVar a) where
 433         (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
 434
 435 -- |Create a new TVar holding a value supplied
 436 newTVar :: a -> STM (TVar a)
 437 newTVar val = STM $ \s1# ->
 438     case newTVar# val s1# of
 439          (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
 440
 441 -- |@IO@ version of 'newTVar'.  This is useful for creating top-level
 442 -- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
 443 -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
 444 -- possible.
 445 newTVarIO :: a -> IO (TVar a)
 446 newTVarIO val = IO $ \s1# ->
 447     case newTVar# val s1# of
 448          (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
 449
 450 -- |Return the current value stored in a TVar
 451 readTVar :: TVar a -> STM a
 452 readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
 453
 454 -- |Write the supplied value into a TVar
 455 writeTVar :: TVar a -> a -> STM ()
 456 writeTVar (TVar tvar#) val = STM $ \s1# ->
 457     case writeTVar# tvar# val s1# of
 458          s2# -> (# s2#, () #)
 459
 460 \end{code}
 461
 462 %************************************************************************
 463 %*                                                                      *
 464 \subsection[mvars]{M-Structures}
 465 %*                                                                      *
 466 %************************************************************************
 467
 468 M-Vars are rendezvous points for concurrent threads.  They begin
 469 empty, and any attempt to read an empty M-Var blocks.  When an M-Var
 470 is written, a single blocked thread may be freed.  Reading an M-Var
 471 toggles its state from full back to empty.  Therefore, any value
 472 written to an M-Var may only be read once.  Multiple reads and writes
 473 are allowed, but there must be at least one read between any two
 474 writes.
 475
 476 \begin{code}
 477 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
 478
 479 -- |Create an 'MVar' which is initially empty.
 480 newEmptyMVar  :: IO (MVar a)
 481 newEmptyMVar = IO $ \ s# ->
 482     case newMVar# s# of
 483          (# s2#, svar# #) -> (# s2#, MVar svar# #)
 484
 485 -- |Create an 'MVar' which contains the supplied value.
 486 newMVar :: a -> IO (MVar a)
 487 newMVar value =
 488     newEmptyMVar        >>= \ mvar ->
 489     putMVar mvar value  >>
 490     return mvar
 491
 492 -- |Return the contents of the 'MVar'.  If the 'MVar' is currently
 493 -- empty, 'takeMVar' will wait until it is full.  After a 'takeMVar',
 494 -- the 'MVar' is left empty.
 495 --
 496 -- There are two further important properties of 'takeMVar':
 497 --
 498 --   * 'takeMVar' is single-wakeup.  That is, if there are multiple
 499 --     threads blocked in 'takeMVar', and the 'MVar' becomes full,
 500 --     only one thread will be woken up.  The runtime guarantees that
 501 --     the woken thread completes its 'takeMVar' operation.
 502 --
 503 --   * When multiple threads are blocked on an 'MVar', they are
 504 --     woken up in FIFO order.  This is useful for providing
 505 --     fairness properties of abstractions built using 'MVar's.
 506 --
 507 takeMVar :: MVar a -> IO a
 508 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
 509
 510 -- |Put a value into an 'MVar'.  If the 'MVar' is currently full,
 511 -- 'putMVar' will wait until it becomes empty.
 512 --
 513 -- There are two further important properties of 'putMVar':
 514 --
 515 --   * 'putMVar' is single-wakeup.  That is, if there are multiple
 516 --     threads blocked in 'putMVar', and the 'MVar' becomes empty,
 517 --     only one thread will be woken up.  The runtime guarantees that
 518 --     the woken thread completes its 'putMVar' operation.
 519 --
 520 --   * When multiple threads are blocked on an 'MVar', they are
 521 --     woken up in FIFO order.  This is useful for providing
 522 --     fairness properties of abstractions built using 'MVar's.
 523 --
 524 putMVar  :: MVar a -> a -> IO ()
 525 putMVar (MVar mvar#) x = IO $ \ s# ->
 526     case putMVar# mvar# x s# of
 527         s2# -> (# s2#, () #)
 528
 529 -- |A non-blocking version of 'takeMVar'.  The 'tryTakeMVar' function
 530 -- returns immediately, with 'Nothing' if the 'MVar' was empty, or
 531 -- @'Just' a@ if the 'MVar' was full with contents @a@.  After 'tryTakeMVar',
 532 -- the 'MVar' is left empty.
 533 tryTakeMVar :: MVar a -> IO (Maybe a)
 534 tryTakeMVar (MVar m) = IO $ \ s ->
 535     case tryTakeMVar# m s of
 536         (# s, 0#, _ #) -> (# s, Nothing #)      -- MVar is empty
 537         (# s, _,  a #) -> (# s, Just a  #)      -- MVar is full
 538
 539 -- |A non-blocking version of 'putMVar'.  The 'tryPutMVar' function
 540 -- attempts to put the value @a@ into the 'MVar', returning 'True' if
 541 -- it was successful, or 'False' otherwise.
 542 tryPutMVar  :: MVar a -> a -> IO Bool
 543 tryPutMVar (MVar mvar#) x = IO $ \ s# ->
 544     case tryPutMVar# mvar# x s# of
 545         (# s, 0# #) -> (# s, False #)
 546         (# s, _  #) -> (# s, True #)
 547
 548 -- |Check whether a given 'MVar' is empty.
 549 --
 550 -- Notice that the boolean value returned  is just a snapshot of
 551 -- the state of the MVar. By the time you get to react on its result,
 552 -- the MVar may have been filled (or emptied) - so be extremely
 553 -- careful when using this operation.   Use 'tryTakeMVar' instead if possible.
 554 isEmptyMVar :: MVar a -> IO Bool
 555 isEmptyMVar (MVar mv#) = IO $ \ s# ->
 556     case isEmptyMVar# mv# s# of
 557         (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
 558
 559 -- |Add a finalizer to an 'MVar' (GHC only).  See "Foreign.ForeignPtr" and
 560 -- "System.Mem.Weak" for more about finalizers.
 561 addMVarFinalizer :: MVar a -> IO () -> IO ()
 562 addMVarFinalizer (MVar m) finalizer =
 563   IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
 564 \end{code}
 565
 566
 567 %************************************************************************
 568 %*                                                                      *
 569 \subsection{Thread waiting}
 570 %*                                                                      *
 571 %************************************************************************
 572
 573 \begin{code}
 574 #ifdef mingw32_HOST_OS
 575
 576 -- Note: threadWaitRead and threadWaitWrite aren't really functional
 577 -- on Win32, but left in there because lib code (still) uses them (the manner
 578 -- in which they're used doesn't cause problems on a Win32 platform though.)
 579
 580 asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
 581 asyncRead  (I# fd) (I# isSock) (I# len) (Ptr buf) =
 582   IO $ \s -> case asyncRead# fd isSock len buf s of
 583                (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
 584
 585 asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
 586 asyncWrite  (I# fd) (I# isSock) (I# len) (Ptr buf) =
 587   IO $ \s -> case asyncWrite# fd isSock len buf s of
 588                (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
 589
 590 asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
 591 asyncDoProc (FunPtr proc) (Ptr param) =
 592     -- the 'length' value is ignored; simplifies implementation of
 593     -- the async*# primops to have them all return the same result.
 594   IO $ \s -> case asyncDoProc# proc param s  of
 595                (# s, len#, err# #) -> (# s, I# err# #)
 596
 597 -- to aid the use of these primops by the IO Handle implementation,
 598 -- provide the following convenience funs:
 599
 600 -- this better be a pinned byte array!
 601 asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
 602 asyncReadBA fd isSock len off bufB =
 603   asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
 604
 605 asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int)
 606 asyncWriteBA fd isSock len off bufB =
 607   asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off)
 608
 609 #endif
 610
 611 -- -----------------------------------------------------------------------------
 612 -- Thread IO API
 613
 614 -- | Block the current thread until data is available to read on the
 615 -- given file descriptor (GHC only).
 616 threadWaitRead :: Fd -> IO ()
 617 threadWaitRead fd
 618 #ifndef mingw32_HOST_OS
 619   | threaded  = waitForReadEvent fd
 620 #endif
 621   | otherwise = IO $ \s ->
 622         case fromIntegral fd of { I# fd# ->
 623         case waitRead# fd# s of { s -> (# s, () #)
 624         }}
 625
 626 -- | Block the current thread until data can be written to the
 627 -- given file descriptor (GHC only).
 628 threadWaitWrite :: Fd -> IO ()
 629 threadWaitWrite fd
 630 #ifndef mingw32_HOST_OS
 631   | threaded  = waitForWriteEvent fd
 632 #endif
 633   | otherwise = IO $ \s ->
 634         case fromIntegral fd of { I# fd# ->
 635         case waitWrite# fd# s of { s -> (# s, () #)
 636         }}
 637
 638 -- | Suspends the current thread for a given number of microseconds
 639 -- (GHC only).
 640 --
 641 -- There is no guarantee that the thread will be rescheduled promptly
 642 -- when the delay has expired, but the thread will never continue to
 643 -- run /earlier/ than specified.
 644 --
 645 threadDelay :: Int -> IO ()
 646 threadDelay time
 647   | threaded  = waitForDelayEvent time
 648   | otherwise = IO $ \s ->
 649         case fromIntegral time of { I# time# ->
 650         case delay# time# s of { s -> (# s, () #)
 651         }}
 652
 653
 654 -- | Set the value of returned TVar to True after a given number of
 655 -- microseconds. The caveats associated with threadDelay also apply.
 656 --
 657 registerDelay :: Int -> IO (TVar Bool)
 658 registerDelay usecs
 659   | threaded = waitForDelayEventSTM usecs
 660   | otherwise = error "registerDelay: requires -threaded"
 661
 662 foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
 663
 664 waitForDelayEvent :: Int -> IO ()
 665 waitForDelayEvent usecs = do
 666   m <- newEmptyMVar
 667   target <- calculateTarget usecs
 668   atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
 669   prodServiceThread
 670   takeMVar m
 671
 672 -- Delays for use in STM
 673 waitForDelayEventSTM :: Int -> IO (TVar Bool)
 674 waitForDelayEventSTM usecs = do
 675    t <- atomically $ newTVar False
 676    target <- calculateTarget usecs
 677    atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))
 678    prodServiceThread
 679    return t
 680
 681 calculateTarget :: Int -> IO USecs
 682 calculateTarget usecs = do
 683     now <- getUSecOfDay
 684     return $ now + (fromIntegral usecs)
 685
 686
 687 -- ----------------------------------------------------------------------------
 688 -- Threaded RTS implementation of threadWaitRead, threadWaitWrite, threadDelay
 689
 690 -- In the threaded RTS, we employ a single IO Manager thread to wait
 691 -- for all outstanding IO requests (threadWaitRead,threadWaitWrite)
 692 -- and delays (threadDelay).
 693 --
 694 -- We can do this because in the threaded RTS the IO Manager can make
 695 -- a non-blocking call to select(), so we don't have to do select() in
 696 -- the scheduler as we have to in the non-threaded RTS.  We get performance
 697 -- benefits from doing it this way, because we only have to restart the select()
 698 -- when a new request arrives, rather than doing one select() each time
 699 -- around the scheduler loop.  Furthermore, the scheduler can be simplified
 700 -- by not having to check for completed IO requests.
 701
 702 -- Issues, possible problems:
 703 --
 704 --      - we might want bound threads to just do the blocking
 705 --        operation rather than communicating with the IO manager
 706 --        thread.  This would prevent simgle-threaded programs which do
 707 --        IO from requiring multiple OS threads.  However, it would also
 708 --        prevent bound threads waiting on IO from being killed or sent
 709 --        exceptions.
 710 --
 711 --      - Apprently exec() doesn't work on Linux in a multithreaded program.
 712 --        I couldn't repeat this.
 713 --
 714 --      - How do we handle signal delivery in the multithreaded RTS?
 715 --
 716 --      - forkProcess will kill the IO manager thread.  Let's just
 717 --        hope we don't need to do any blocking IO between fork & exec.
 718
 719 #ifndef mingw32_HOST_OS
 720 data IOReq
 721   = Read   {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
 722   | Write  {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
 723 #endif
 724
 725 data DelayReq
 726   = Delay    {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ())
 727   | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
 728
 729 #ifndef mingw32_HOST_OS
 730 pendingEvents :: IORef [IOReq]
 731 #endif
 732 pendingDelays :: IORef [DelayReq]
 733         -- could use a strict list or array here
 734 {-# NOINLINE pendingEvents #-}
 735 {-# NOINLINE pendingDelays #-}
 736 (pendingEvents,pendingDelays) = unsafePerformIO $ do
 737   startIOManagerThread
 738   reqs <- newIORef []
 739   dels <- newIORef []
 740   return (reqs, dels)
 741         -- the first time we schedule an IO request, the service thread
 742         -- will be created (cool, huh?)
 743
 744 ensureIOManagerIsRunning :: IO ()
 745 ensureIOManagerIsRunning
 746   | threaded  = seq pendingEvents $ return ()
 747   | otherwise = return ()
 748
 749 insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
 750 insertDelay d [] = [d]
 751 insertDelay d1 ds@(d2 : rest)
 752   | delayTime d1 <= delayTime d2 = d1 : ds
 753   | otherwise                    = d2 : insertDelay d1 rest
 754
 755 delayTime :: DelayReq -> USecs
 756 delayTime (Delay t _) = t
 757 delayTime (DelaySTM t _) = t
 758
 759 type USecs = Word64
 760
 761 -- XXX: move into GHC.IOBase from Data.IORef?
 762 atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b
 763 atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s
 764
 765 foreign import ccall unsafe "getUSecOfDay"
 766   getUSecOfDay :: IO USecs
 767
 768 prodding :: IORef Bool
 769 {-# NOINLINE prodding #-}
 770 prodding = unsafePerformIO (newIORef False)
 771
 772 prodServiceThread :: IO ()
 773 prodServiceThread = do
 774   was_set <- atomicModifyIORef prodding (\a -> (True,a))
 775   if (not (was_set)) then wakeupIOManager else return ()
 776
 777 #ifdef mingw32_HOST_OS
 778 -- ----------------------------------------------------------------------------
 779 -- Windows IO manager thread
 780
 781 startIOManagerThread :: IO ()
 782 startIOManagerThread = do
 783   wakeup <- c_getIOManagerEvent
 784   forkIO $ service_loop wakeup []
 785   return ()
 786
 787 service_loop :: HANDLE          -- read end of pipe
 788              -> [DelayReq]      -- current delay requests
 789              -> IO ()
 790
 791 service_loop wakeup old_delays = do
 792   -- pick up new delay requests
 793   new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
 794   let  delays = foldr insertDelay old_delays new_delays
 795
 796   now <- getUSecOfDay
 797   (delays', timeout) <- getDelay now delays
 798
 799   r <- c_WaitForSingleObject wakeup timeout
 800   case r of
 801     0xffffffff -> do c_maperrno; throwErrno "service_loop"
 802     0 -> do
 803         r <- c_readIOManagerEvent
 804         exit <-
 805               case r of
 806                 _ | r == io_MANAGER_WAKEUP -> return False
 807                 _ | r == io_MANAGER_DIE    -> return True
 808                 0 -> return False -- spurious wakeup
 809                 r -> do start_console_handler (r `shiftR` 1); return False
 810         if exit
 811           then return ()
 812           else service_cont wakeup delays'
 813
 814     _other -> service_cont wakeup delays' -- probably timeout
 815
 816 service_cont wakeup delays = do
 817   atomicModifyIORef prodding (\_ -> (False,False))
 818   service_loop wakeup delays
 819
 820 -- must agree with rts/win32/ThrIOManager.c
 821 io_MANAGER_WAKEUP = 0xffffffff :: Word32
 822 io_MANAGER_DIE    = 0xfffffffe :: Word32
 823
 824 start_console_handler :: Word32 -> IO ()
 825 start_console_handler r = do
 826   stableptr <- peek console_handler
 827   forkIO $ do io <- deRefStablePtr stableptr; io (fromIntegral r)
 828   return ()
 829
 830 foreign import ccall "&console_handler"
 831    console_handler :: Ptr (StablePtr (CInt -> IO ()))
 832
 833 stick :: IORef HANDLE
 834 {-# NOINLINE stick #-}
 835 stick = unsafePerformIO (newIORef nullPtr)
 836
 837 wakeupIOManager = do
 838   hdl <- readIORef stick
 839   c_sendIOManagerEvent io_MANAGER_WAKEUP
 840
 841 -- Walk the queue of pending delays, waking up any that have passed
 842 -- and return the smallest delay to wait for.  The queue of pending
 843 -- delays is kept ordered.
 844 getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
 845 getDelay now [] = return ([], iNFINITE)
 846 getDelay now all@(d : rest)
 847   = case d of
 848      Delay time m | now >= time -> do
 849         putMVar m ()
 850         getDelay now rest
 851      DelaySTM time t | now >= time -> do
 852         atomically $ writeTVar t True
 853         getDelay now rest
 854      _otherwise ->
 855         -- delay is in millisecs for WaitForSingleObject
 856         let micro_seconds = delayTime d - now
 857             milli_seconds = (micro_seconds + 999) `div` 1000
 858         in return (all, fromIntegral milli_seconds)
 859
 860 -- ToDo: this just duplicates part of System.Win32.Types, which isn't
 861 -- available yet.  We should move some Win32 functionality down here,
 862 -- maybe as part of the grand reorganisation of the base package...
 863 type HANDLE       = Ptr ()
 864 type DWORD        = Word32
 865
 866 iNFINITE = 0xFFFFFFFF :: DWORD -- urgh
 867
 868 foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
 869   c_getIOManagerEvent :: IO HANDLE
 870
 871 foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
 872   c_readIOManagerEvent :: IO Word32
 873
 874 foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
 875   c_sendIOManagerEvent :: Word32 -> IO ()
 876
 877 foreign import ccall unsafe "maperrno"             -- in Win32Utils.c
 878    c_maperrno :: IO ()
 879
 880 foreign import stdcall "WaitForSingleObject"
 881    c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD
 882
 883 #else
 884 -- ----------------------------------------------------------------------------
 885 -- Unix IO manager thread, using select()
 886
 887 startIOManagerThread :: IO ()
 888 startIOManagerThread = do
 889         allocaArray 2 $ \fds -> do
 890         throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)
 891         rd_end <- peekElemOff fds 0
 892         wr_end <- peekElemOff fds 1
 893         writeIORef stick (fromIntegral wr_end)
 894         c_setIOManagerPipe wr_end
 895         forkIO $ do
 896             allocaBytes sizeofFdSet   $ \readfds -> do
 897             allocaBytes sizeofFdSet   $ \writefds -> do
 898             allocaBytes sizeofTimeVal $ \timeval -> do
 899             service_loop (fromIntegral rd_end) readfds writefds timeval [] []
 900         return ()
 901
 902 service_loop
 903    :: Fd                -- listen to this for wakeup calls
 904    -> Ptr CFdSet
 905    -> Ptr CFdSet
 906    -> Ptr CTimeVal
 907    -> [IOReq]
 908    -> [DelayReq]
 909    -> IO ()
 910 service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
 911
 912   -- pick up new IO requests
 913   new_reqs <- atomicModifyIORef pendingEvents (\a -> ([],a))
 914   let reqs = new_reqs ++ old_reqs
 915
 916   -- pick up new delay requests
 917   new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
 918   let  delays = foldr insertDelay old_delays new_delays
 919
 920   -- build the FDSets for select()
 921   fdZero readfds
 922   fdZero writefds
 923   fdSet wakeup readfds
 924   maxfd <- buildFdSets 0 readfds writefds reqs
 925
 926   -- perform the select()
 927   let do_select delays = do
 928           -- check the current time and wake up any thread in
 929           -- threadDelay whose timeout has expired.  Also find the
 930           -- timeout value for the select() call.
 931           now <- getUSecOfDay
 932           (delays', timeout) <- getDelay now ptimeval delays
 933
 934           res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds
 935                         nullPtr timeout
 936           if (res == -1)
 937              then do
 938                 err <- getErrno
 939                 case err of
 940                   _ | err == eINTR ->  do_select delays'
 941                         -- EINTR: just redo the select()
 942                   _ | err == eBADF ->  return (True, delays)
 943                         -- EBADF: one of the file descriptors is closed or bad,
 944                         -- we don't know which one, so wake everyone up.
 945                   _ | otherwise    ->  throwErrno "select"
 946                         -- otherwise (ENOMEM or EINVAL) something has gone
 947                         -- wrong; report the error.
 948              else
 949                 return (False,delays')
 950
 951   (wakeup_all,delays') <- do_select delays
 952
 953   exit <-
 954     if wakeup_all then return False
 955       else do
 956         b <- fdIsSet wakeup readfds
 957         if b == 0
 958           then return False
 959           else alloca $ \p -> do
 960                  c_read (fromIntegral wakeup) p 1; return ()
 961                  s <- peek p
 962                  case s of
 963                   _ | s == io_MANAGER_WAKEUP -> return False
 964                   _ | s == io_MANAGER_DIE    -> return True
 965                   _ -> withMVar signalHandlerLock $ \_ -> do
 966                           handler_tbl <- peek handlers
 967                           sp <- peekElemOff handler_tbl (fromIntegral s)
 968                           io <- deRefStablePtr sp
 969                           forkIO io
 970                           return False
 971
 972   if exit then return () else do
 973
 974   atomicModifyIORef prodding (\_ -> (False,False))
 975
 976   reqs' <- if wakeup_all then do wakeupAll reqs; return []
 977                          else completeRequests reqs readfds writefds []
 978
 979   service_loop wakeup readfds writefds ptimeval reqs' delays'
 980
 981 withMVar :: MVar a -> (a -> IO b) -> IO b
 982 withMVar m io =
 983   block $ do
 984     a <- takeMVar m
 985     b <- catchException (unblock (io a))
 986             (\e -> do putMVar m a; throw e)
 987     putMVar m a
 988     return b
 989
 990 io_MANAGER_WAKEUP = 0xff :: CChar
 991 io_MANAGER_DIE    = 0xfe :: CChar
 992
 993 stick :: IORef Fd
 994 {-# NOINLINE stick #-}
 995 stick = unsafePerformIO (newIORef 0)
 996
 997 wakeupIOManager :: IO ()
 998 wakeupIOManager = do
 999   fd <- readIORef stick
1000   with io_MANAGER_WAKEUP $ \pbuf -> do
1001     c_write (fromIntegral fd) pbuf 1; return ()
1002
1003 -- Lock used to protect concurrent access to signal_handlers.  Symptom of
1004 -- this race condition is #1922, although that bug was on Windows a similar
1005 -- bug also exists on Unix.
1006 signalHandlerLock :: MVar ()
1007 signalHandlerLock = unsafePerformIO (newMVar ())
1008
1009 foreign import ccall "&signal_handlers" handlers :: Ptr (Ptr (StablePtr (IO ())))
1010
1011 foreign import ccall "setIOManagerPipe"
1012   c_setIOManagerPipe :: CInt -> IO ()
1013
1014 -- -----------------------------------------------------------------------------
1015 -- IO requests
1016
1017 buildFdSets maxfd readfds writefds [] = return maxfd
1018 buildFdSets maxfd readfds writefds (Read fd m : reqs)
1019   | fd >= fD_SETSIZE =  error "buildFdSets: file descriptor out of range"
1020   | otherwise        =  do
1021         fdSet fd readfds
1022         buildFdSets (max maxfd fd) readfds writefds reqs
1023 buildFdSets maxfd readfds writefds (Write fd m : reqs)
1024   | fd >= fD_SETSIZE =  error "buildFdSets: file descriptor out of range"
1025   | otherwise        =  do
1026         fdSet fd writefds
1027         buildFdSets (max maxfd fd) readfds writefds reqs
1028
1029 completeRequests [] _ _ reqs' = return reqs'
1030 completeRequests (Read fd m : reqs) readfds writefds reqs' = do
1031   b <- fdIsSet fd readfds
1032   if b /= 0
1033     then do putMVar m (); completeRequests reqs readfds writefds reqs'
1034     else completeRequests reqs readfds writefds (Read fd m : reqs')
1035 completeRequests (Write fd m : reqs) readfds writefds reqs' = do
1036   b <- fdIsSet fd writefds
1037   if b /= 0
1038     then do putMVar m (); completeRequests reqs readfds writefds reqs'
1039     else completeRequests reqs readfds writefds (Write fd m : reqs')
1040
1041 wakeupAll [] = return ()
1042 wakeupAll (Read  fd m : reqs) = do putMVar m (); wakeupAll reqs
1043 wakeupAll (Write fd m : reqs) = do putMVar m (); wakeupAll reqs
1044
1045 waitForReadEvent :: Fd -> IO ()
1046 waitForReadEvent fd = do
1047   m <- newEmptyMVar
1048   atomicModifyIORef pendingEvents (\xs -> (Read fd m : xs, ()))
1049   prodServiceThread
1050   takeMVar m
1051
1052 waitForWriteEvent :: Fd -> IO ()
1053 waitForWriteEvent fd = do
1054   m <- newEmptyMVar
1055   atomicModifyIORef pendingEvents (\xs -> (Write fd m : xs, ()))
1056   prodServiceThread
1057   takeMVar m
1058
1059 -- -----------------------------------------------------------------------------
1060 -- Delays
1061
1062 -- Walk the queue of pending delays, waking up any that have passed
1063 -- and return the smallest delay to wait for.  The queue of pending
1064 -- delays is kept ordered.
1065 getDelay :: USecs -> Ptr CTimeVal -> [DelayReq] -> IO ([DelayReq], Ptr CTimeVal)
1066 getDelay now ptimeval [] = return ([],nullPtr)
1067 getDelay now ptimeval all@(d : rest)
1068   = case d of
1069      Delay time m | now >= time -> do
1070         putMVar m ()
1071         getDelay now ptimeval rest
1072      DelaySTM time t | now >= time -> do
1073         atomically $ writeTVar t True
1074         getDelay now ptimeval rest
1075      _otherwise -> do
1076         setTimevalTicks ptimeval (delayTime d - now)
1077         return (all,ptimeval)
1078
1079 newtype CTimeVal = CTimeVal ()
1080
1081 foreign import ccall unsafe "sizeofTimeVal"
1082   sizeofTimeVal :: Int
1083
1084 foreign import ccall unsafe "setTimevalTicks"
1085   setTimevalTicks :: Ptr CTimeVal -> USecs -> IO ()
1086
1087 {-
1088   On Win32 we're going to have a single Pipe, and a
1089   waitForSingleObject with the delay time.  For signals, we send a
1090   byte down the pipe just like on Unix.
1091 -}
1092
1093 -- ----------------------------------------------------------------------------
1094 -- select() interface
1095
1096 -- ToDo: move to System.Posix.Internals?
1097
1098 newtype CFdSet = CFdSet ()
1099
1100 foreign import ccall safe "select"
1101   c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
1102            -> IO CInt
1103
1104 foreign import ccall unsafe "hsFD_SETSIZE"
1105   c_fD_SETSIZE :: CInt
1106
1107 fD_SETSIZE :: Fd
1108 fD_SETSIZE = fromIntegral c_fD_SETSIZE
1109
1110 foreign import ccall unsafe "hsFD_CLR"
1111   c_fdClr :: CInt -> Ptr CFdSet -> IO ()
1112
1113 fdClr :: Fd -> Ptr CFdSet -> IO ()
1114 fdClr (Fd fd) fdset = c_fdClr fd fdset
1115
1116 foreign import ccall unsafe "hsFD_ISSET"
1117   c_fdIsSet :: CInt -> Ptr CFdSet -> IO CInt
1118
1119 fdIsSet :: Fd -> Ptr CFdSet -> IO CInt
1120 fdIsSet (Fd fd) fdset = c_fdIsSet fd fdset
1121
1122 foreign import ccall unsafe "hsFD_SET"
1123   c_fdSet :: CInt -> Ptr CFdSet -> IO ()
1124
1125 fdSet :: Fd -> Ptr CFdSet -> IO ()
1126 fdSet (Fd fd) fdset = c_fdSet fd fdset
1127
1128 foreign import ccall unsafe "hsFD_ZERO"
1129   fdZero :: Ptr CFdSet -> IO ()
1130
1131 foreign import ccall unsafe "sizeof_fd_set"
1132   sizeofFdSet :: Int
1133
1134 #endif
1135
1136 \end{code}