+-- given file descriptor (GHC only).
+threadWaitWrite :: Fd -> IO ()
+threadWaitWrite fd
+#ifndef mingw32_HOST_OS
+ | threaded = waitForWriteEvent fd
+#endif
+ | otherwise = IO $ \s ->
+ case fromIntegral fd of { I# fd# ->
+ case waitWrite# fd# s of { s -> (# s, () #)
+ }}
+
+-- | Suspends the current thread for a given number of microseconds
+-- (GHC only).
+--
+-- Note that the resolution used by the Haskell runtime system's
+-- internal timer is 1\/50 second, and 'threadDelay' will round its
+-- argument up to the nearest multiple of this resolution.
+--
+-- There is no guarantee that the thread will be rescheduled promptly
+-- when the delay has expired, but the thread will never continue to
+-- run /earlier/ than specified.
+--
+threadDelay :: Int -> IO ()
+threadDelay time
+#ifndef mingw32_HOST_OS
+ | threaded = waitForDelayEvent time
+#else
+ | threaded = c_Sleep (fromIntegral (time `quot` 1000))
+#endif
+ | otherwise = IO $ \s ->
+ case fromIntegral time of { I# time# ->
+ case delay# time# s of { s -> (# s, () #)
+ }}
+
+registerDelay :: Int -> IO (TVar Bool)
+registerDelay usecs
+#ifndef mingw32_HOST_OS
+ | threaded = waitForDelayEventSTM usecs
+ | otherwise = error "registerDelay: requires -threaded"
+#else
+ = error "registerDelay: not currently supported on Windows"
+#endif
+
+-- On Windows, we just make a safe call to 'Sleep' to implement threadDelay.
+#ifdef mingw32_HOST_OS
+foreign import stdcall safe "Sleep" c_Sleep :: CInt -> IO ()
+#endif
+
+foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
+
+-- ----------------------------------------------------------------------------
+-- Threaded RTS implementation of threadWaitRead, threadWaitWrite, threadDelay
+
+-- In the threaded RTS, we employ a single IO Manager thread to wait
+-- for all outstanding IO requests (threadWaitRead,threadWaitWrite)
+-- and delays (threadDelay).
+--
+-- We can do this because in the threaded RTS the IO Manager can make
+-- a non-blocking call to select(), so we don't have to do select() in
+-- the scheduler as we have to in the non-threaded RTS. We get performance
+-- benefits from doing it this way, because we only have to restart the select()
+-- when a new request arrives, rather than doing one select() each time
+-- around the scheduler loop. Furthermore, the scheduler can be simplified
+-- by not having to check for completed IO requests.
+
+-- Issues, possible problems:
+--
+-- - we might want bound threads to just do the blocking
+-- operation rather than communicating with the IO manager
+-- thread. This would prevent simgle-threaded programs which do
+-- IO from requiring multiple OS threads. However, it would also
+-- prevent bound threads waiting on IO from being killed or sent
+-- exceptions.
+--
+-- - Apprently exec() doesn't work on Linux in a multithreaded program.
+-- I couldn't repeat this.
+--
+-- - How do we handle signal delivery in the multithreaded RTS?
+--
+-- - forkProcess will kill the IO manager thread. Let's just
+-- hope we don't need to do any blocking IO between fork & exec.
+
+#ifndef mingw32_HOST_OS
+
+data IOReq
+ = Read {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
+ | Write {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
+
+data DelayReq
+ = Delay {-# UNPACK #-} !Int {-# UNPACK #-} !(MVar ())
+ | DelaySTM {-# UNPACK #-} !Int {-# UNPACK #-} !(TVar Bool)
+
+pendingEvents :: IORef [IOReq]
+pendingDelays :: IORef [DelayReq]
+ -- could use a strict list or array here
+{-# NOINLINE pendingEvents #-}
+{-# NOINLINE pendingDelays #-}
+(pendingEvents,pendingDelays) = unsafePerformIO $ do
+ startIOManagerThread
+ reqs <- newIORef []
+ dels <- newIORef []
+ return (reqs, dels)
+ -- the first time we schedule an IO request, the service thread
+ -- will be created (cool, huh?)
+
+ensureIOManagerIsRunning :: IO ()
+ensureIOManagerIsRunning
+ | threaded = seq pendingEvents $ return ()
+ | otherwise = return ()
+
+startIOManagerThread :: IO ()
+startIOManagerThread = do
+ allocaArray 2 $ \fds -> do
+ throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)
+ rd_end <- peekElemOff fds 0
+ wr_end <- peekElemOff fds 1
+ writeIORef stick (fromIntegral wr_end)
+ c_setIOManagerPipe wr_end
+ forkIO $ do
+ allocaBytes sizeofFdSet $ \readfds -> do
+ allocaBytes sizeofFdSet $ \writefds -> do
+ allocaBytes sizeofTimeVal $ \timeval -> do
+ service_loop (fromIntegral rd_end) readfds writefds timeval [] []
+ return ()
+
+service_loop
+ :: Fd -- listen to this for wakeup calls
+ -> Ptr CFdSet
+ -> Ptr CFdSet
+ -> Ptr CTimeVal
+ -> [IOReq]
+ -> [DelayReq]
+ -> IO ()
+service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
+
+ -- pick up new IO requests
+ new_reqs <- atomicModifyIORef pendingEvents (\a -> ([],a))
+ let reqs = new_reqs ++ old_reqs
+
+ -- pick up new delay requests
+ new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
+ let delays = foldr insertDelay old_delays new_delays
+
+ -- build the FDSets for select()
+ fdZero readfds
+ fdZero writefds
+ fdSet wakeup readfds
+ maxfd <- buildFdSets 0 readfds writefds reqs
+
+ -- perform the select()
+ let do_select delays = do
+ -- check the current time and wake up any thread in
+ -- threadDelay whose timeout has expired. Also find the
+ -- timeout value for the select() call.
+ now <- getTicksOfDay
+ (delays', timeout) <- getDelay now ptimeval delays
+
+ res <- c_select ((max wakeup maxfd)+1) readfds writefds
+ nullPtr timeout
+ if (res == -1)
+ then do
+ err <- getErrno
+ case err of
+ _ | err == eINTR -> do_select delays'
+ -- EINTR: just redo the select()
+ _ | err == eBADF -> return (True, delays)
+ -- EBADF: one of the file descriptors is closed or bad,
+ -- we don't know which one, so wake everyone up.
+ _ | otherwise -> throwErrno "select"
+ -- otherwise (ENOMEM or EINVAL) something has gone
+ -- wrong; report the error.
+ else
+ return (False,delays')
+
+ (wakeup_all,delays') <- do_select delays
+
+ exit <-
+ if wakeup_all then return False
+ else do
+ b <- fdIsSet wakeup readfds
+ if b == 0
+ then return False
+ else alloca $ \p -> do
+ c_read (fromIntegral wakeup) p 1; return ()
+ s <- peek p
+ case s of
+ _ | s == io_MANAGER_WAKEUP -> return False
+ _ | s == io_MANAGER_DIE -> return True
+ _ -> do handler_tbl <- peek handlers
+ sp <- peekElemOff handler_tbl (fromIntegral s)
+ forkIO (do io <- deRefStablePtr sp; io)
+ return False
+
+ if exit then return () else do
+
+ takeMVar prodding
+ putMVar prodding False
+
+ reqs' <- if wakeup_all then do wakeupAll reqs; return []
+ else completeRequests reqs readfds writefds []
+
+ service_loop wakeup readfds writefds ptimeval reqs' delays'
+
+stick :: IORef Fd
+{-# NOINLINE stick #-}
+stick = unsafePerformIO (newIORef 0)
+
+io_MANAGER_WAKEUP = 0xff :: CChar
+io_MANAGER_DIE = 0xfe :: CChar
+
+prodding :: MVar Bool
+{-# NOINLINE prodding #-}
+prodding = unsafePerformIO (newMVar False)
+
+prodServiceThread :: IO ()
+prodServiceThread = do
+ b <- takeMVar prodding
+ if (not b)
+ then do fd <- readIORef stick
+ with io_MANAGER_WAKEUP $ \pbuf -> do
+ c_write (fromIntegral fd) pbuf 1; return ()
+ else return ()
+ putMVar prodding True
+
+foreign import ccall "&signal_handlers" handlers :: Ptr (Ptr (StablePtr (IO ())))
+
+foreign import ccall "setIOManagerPipe"
+ c_setIOManagerPipe :: CInt -> IO ()
+
+-- -----------------------------------------------------------------------------
+-- IO requests
+
+buildFdSets maxfd readfds writefds [] = return maxfd
+buildFdSets maxfd readfds writefds (Read fd m : reqs)
+ | fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range"
+ | otherwise = do
+ fdSet fd readfds
+ buildFdSets (max maxfd fd) readfds writefds reqs
+buildFdSets maxfd readfds writefds (Write fd m : reqs)
+ | fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range"
+ | otherwise = do
+ fdSet fd writefds
+ buildFdSets (max maxfd fd) readfds writefds reqs
+
+completeRequests [] _ _ reqs' = return reqs'
+completeRequests (Read fd m : reqs) readfds writefds reqs' = do
+ b <- fdIsSet fd readfds
+ if b /= 0
+ then do putMVar m (); completeRequests reqs readfds writefds reqs'
+ else completeRequests reqs readfds writefds (Read fd m : reqs')
+completeRequests (Write fd m : reqs) readfds writefds reqs' = do
+ b <- fdIsSet fd writefds
+ if b /= 0
+ then do putMVar m (); completeRequests reqs readfds writefds reqs'
+ else completeRequests reqs readfds writefds (Write fd m : reqs')
+
+wakeupAll [] = return ()
+wakeupAll (Read fd m : reqs) = do putMVar m (); wakeupAll reqs
+wakeupAll (Write fd m : reqs) = do putMVar m (); wakeupAll reqs
+
+waitForReadEvent :: Fd -> IO ()
+waitForReadEvent fd = do
+ m <- newEmptyMVar
+ atomicModifyIORef pendingEvents (\xs -> (Read fd m : xs, ()))
+ prodServiceThread
+ takeMVar m
+
+waitForWriteEvent :: Fd -> IO ()
+waitForWriteEvent fd = do
+ m <- newEmptyMVar
+ atomicModifyIORef pendingEvents (\xs -> (Write fd m : xs, ()))
+ prodServiceThread
+ takeMVar m
+
+-- XXX: move into GHC.IOBase from Data.IORef?
+atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b
+atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s
+
+-- -----------------------------------------------------------------------------
+-- Delays
+
+waitForDelayEvent :: Int -> IO ()
+waitForDelayEvent usecs = do
+ m <- newEmptyMVar
+ now <- getTicksOfDay
+ let target = now + usecs `quot` tick_usecs
+ atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ()))
+ prodServiceThread
+ takeMVar m
+
+-- Delays for use in STM
+waitForDelayEventSTM :: Int -> IO (TVar Bool)
+waitForDelayEventSTM usecs = do
+ t <- atomically $ newTVar False
+ now <- getTicksOfDay
+ let target = now + usecs `quot` tick_usecs
+ atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ()))
+ prodServiceThread
+ return t
+
+-- Walk the queue of pending delays, waking up any that have passed
+-- and return the smallest delay to wait for. The queue of pending
+-- delays is kept ordered.
+getDelay :: Ticks -> Ptr CTimeVal -> [DelayReq] -> IO ([DelayReq], Ptr CTimeVal)
+getDelay now ptimeval [] = return ([],nullPtr)
+getDelay now ptimeval all@(d : rest)
+ = case d of
+ Delay time m | now >= time -> do
+ putMVar m ()
+ getDelay now ptimeval rest
+ DelaySTM time t | now >= time -> do
+ atomically $ writeTVar t True
+ getDelay now ptimeval rest
+ _otherwise -> do
+ setTimevalTicks ptimeval (delayTime d - now)
+ return (all,ptimeval)
+
+insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
+insertDelay d [] = [d]
+insertDelay d1 ds@(d2 : rest)
+ | delayTime d1 <= delayTime d2 = d1 : ds
+ | otherwise = d2 : insertDelay d1 rest
+
+delayTime (Delay t _) = t
+delayTime (DelaySTM t _) = t
+
+type Ticks = Int
+tick_freq = 50 :: Ticks -- accuracy of threadDelay (ticks per sec)
+tick_usecs = 1000000 `quot` tick_freq :: Int
+
+newtype CTimeVal = CTimeVal ()
+
+foreign import ccall unsafe "sizeofTimeVal"
+ sizeofTimeVal :: Int
+
+foreign import ccall unsafe "getTicksOfDay"
+ getTicksOfDay :: IO Ticks
+
+foreign import ccall unsafe "setTimevalTicks"
+ setTimevalTicks :: Ptr CTimeVal -> Ticks -> IO ()
+
+-- ----------------------------------------------------------------------------
+-- select() interface
+
+-- ToDo: move to System.Posix.Internals?
+
+newtype CFdSet = CFdSet ()
+
+foreign import ccall safe "select"
+ c_select :: Fd -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
+ -> IO CInt
+
+foreign import ccall unsafe "hsFD_SETSIZE"
+ fD_SETSIZE :: Fd
+
+foreign import ccall unsafe "hsFD_CLR"
+ fdClr :: Fd -> Ptr CFdSet -> IO ()
+
+foreign import ccall unsafe "hsFD_ISSET"
+ fdIsSet :: Fd -> Ptr CFdSet -> IO CInt
+
+foreign import ccall unsafe "hsFD_SET"
+ fdSet :: Fd -> Ptr CFdSet -> IO ()
+
+foreign import ccall unsafe "hsFD_ZERO"
+ fdZero :: Ptr CFdSet -> IO ()
+
+foreign import ccall unsafe "sizeof_fd_set"
+ sizeofFdSet :: Int
+
+#endif