-pendingEvents :: IORef [IOReq]
-#endif
-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 ()
-
-insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
-insertDelay d [] = [d]
-insertDelay d1 ds@(d2 : rest)
- | delayTime d1 <= delayTime d2 = d1 : ds
- | otherwise = d2 : insertDelay d1 rest
-
-delayTime :: DelayReq -> USecs
-delayTime (Delay t _) = t
-delayTime (DelaySTM t _) = t
-
-type USecs = Word64
-
--- 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
-
-foreign import ccall unsafe "getUSecOfDay"
- getUSecOfDay :: IO USecs
-
-prodding :: IORef Bool
-{-# NOINLINE prodding #-}
-prodding = unsafePerformIO (newIORef False)
-
-prodServiceThread :: IO ()
-prodServiceThread = do
- was_set <- atomicModifyIORef prodding (\a -> (True,a))
- if (not (was_set)) then wakeupIOManager else return ()
-
-#ifdef mingw32_HOST_OS
--- ----------------------------------------------------------------------------
--- Windows IO manager thread
-
-startIOManagerThread :: IO ()
-startIOManagerThread = do
- wakeup <- c_getIOManagerEvent
- forkIO $ service_loop wakeup []
- return ()
-
-service_loop :: HANDLE -- read end of pipe
- -> [DelayReq] -- current delay requests
- -> IO ()
-
-service_loop wakeup old_delays = do
- -- pick up new delay requests
- new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
- let delays = foldr insertDelay old_delays new_delays
-
- now <- getUSecOfDay
- (delays', timeout) <- getDelay now delays
-
- r <- c_WaitForSingleObject wakeup timeout
- case r of
- 0xffffffff -> do c_maperrno; throwErrno "service_loop"
- 0 -> do
- r <- c_readIOManagerEvent
- exit <-
- case r of
- _ | r == io_MANAGER_WAKEUP -> return False
- _ | r == io_MANAGER_DIE -> return True
- 0 -> return False -- spurious wakeup
- r -> do start_console_handler (r `shiftR` 1); return False
- if exit
- then return ()
- else service_cont wakeup delays'
-
- _other -> service_cont wakeup delays' -- probably timeout
-
-service_cont wakeup delays = do
- atomicModifyIORef prodding (\_ -> (False,False))
- service_loop wakeup delays
-
--- must agree with rts/win32/ThrIOManager.c
-io_MANAGER_WAKEUP = 0xffffffff :: Word32
-io_MANAGER_DIE = 0xfffffffe :: Word32
-
-start_console_handler :: Word32 -> IO ()
-start_console_handler r = do
- stableptr <- peek console_handler
- forkIO $ do io <- deRefStablePtr stableptr; io (fromIntegral r)
- return ()
-
-foreign import ccall "&console_handler"
- console_handler :: Ptr (StablePtr (CInt -> IO ()))
-
-stick :: IORef HANDLE
-{-# NOINLINE stick #-}
-stick = unsafePerformIO (newIORef nullPtr)
-
-wakeupIOManager = do
- hdl <- readIORef stick
- c_sendIOManagerEvent io_MANAGER_WAKEUP
-
--- 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 :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD)
-getDelay now [] = return ([], iNFINITE)
-getDelay now all@(d : rest)
- = case d of
- Delay time m | now >= time -> do
- putMVar m ()
- getDelay now rest
- DelaySTM time t | now >= time -> do
- atomically $ writeTVar t True
- getDelay now rest
- _otherwise ->
- -- delay is in millisecs for WaitForSingleObject
- let micro_seconds = delayTime d - now
- milli_seconds = (micro_seconds + 999) `div` 1000
- in return (all, fromIntegral milli_seconds)
-
--- ToDo: this just duplicates part of System.Win32.Types, which isn't
--- available yet. We should move some Win32 functionality down here,
--- maybe as part of the grand reorganisation of the base package...
-type HANDLE = Ptr ()
-type DWORD = Word32
-
-iNFINITE = 0xFFFFFFFF :: DWORD -- urgh
-
-foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c)
- c_getIOManagerEvent :: IO HANDLE
-
-foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c)
- c_readIOManagerEvent :: IO Word32
-
-foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
- c_sendIOManagerEvent :: Word32 -> IO ()
-
-foreign import ccall unsafe "maperrno" -- in Win32Utils.c
- c_maperrno :: IO ()
-
-foreign import stdcall "WaitForSingleObject"
- c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD
-
-#else
--- ----------------------------------------------------------------------------
--- Unix IO manager thread, using select()
-
-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 <- getUSecOfDay
- (delays', timeout) <- getDelay now ptimeval delays
-
- res <- c_select (fromIntegral ((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
- _ -> withMVar signalHandlerLock $ \_ -> do
- handler_tbl <- peek handlers
- sp <- peekElemOff handler_tbl (fromIntegral s)
- io <- deRefStablePtr sp
- forkIO io
- return False
-
- if exit then return () else do
-
- atomicModifyIORef prodding (\_ -> (False,False))
-
- reqs' <- if wakeup_all then do wakeupAll reqs; return []
- else completeRequests reqs readfds writefds []
-
- service_loop wakeup readfds writefds ptimeval reqs' delays'
-
-withMVar :: MVar a -> (a -> IO b) -> IO b
-withMVar m io =
- block $ do
- a <- takeMVar m
- b <- catchException (unblock (io a))
- (\e -> do putMVar m a; throw e)
- putMVar m a
- return b
-
-io_MANAGER_WAKEUP = 0xff :: CChar
-io_MANAGER_DIE = 0xfe :: CChar
-
-stick :: IORef Fd
-{-# NOINLINE stick #-}
-stick = unsafePerformIO (newIORef 0)
-
-wakeupIOManager :: IO ()
-wakeupIOManager = do
- fd <- readIORef stick
- with io_MANAGER_WAKEUP $ \pbuf -> do
- c_write (fromIntegral fd) pbuf 1; return ()
-
--- Lock used to protect concurrent access to signal_handlers. Symptom of
--- this race condition is #1922, although that bug was on Windows a similar
--- bug also exists on Unix.
-signalHandlerLock :: MVar ()
-signalHandlerLock = unsafePerformIO (newMVar ())
-
-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
-
--- -----------------------------------------------------------------------------
--- Delays
-
--- 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 :: USecs -> 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)
-
-newtype CTimeVal = CTimeVal ()
-
-foreign import ccall unsafe "sizeofTimeVal"
- sizeofTimeVal :: Int
-
-foreign import ccall unsafe "setTimevalTicks"
- setTimevalTicks :: Ptr CTimeVal -> USecs -> IO ()
-
-{-
- On Win32 we're going to have a single Pipe, and a
- waitForSingleObject with the delay time. For signals, we send a
- byte down the pipe just like on Unix.
--}
-
--- ----------------------------------------------------------------------------
--- select() interface
-
--- ToDo: move to System.Posix.Internals?
-
-newtype CFdSet = CFdSet ()
-
-foreign import ccall safe "select"
- c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
- -> IO CInt
-
-foreign import ccall unsafe "hsFD_SETSIZE"
- c_fD_SETSIZE :: CInt
-
-fD_SETSIZE :: Fd
-fD_SETSIZE = fromIntegral c_fD_SETSIZE
-
-foreign import ccall unsafe "hsFD_CLR"
- c_fdClr :: CInt -> Ptr CFdSet -> IO ()
-
-fdClr :: Fd -> Ptr CFdSet -> IO ()
-fdClr (Fd fd) fdset = c_fdClr fd fdset
-
-foreign import ccall unsafe "hsFD_ISSET"
- c_fdIsSet :: CInt -> Ptr CFdSet -> IO CInt
-
-fdIsSet :: Fd -> Ptr CFdSet -> IO CInt
-fdIsSet (Fd fd) fdset = c_fdIsSet fd fdset
-
-foreign import ccall unsafe "hsFD_SET"
- c_fdSet :: CInt -> Ptr CFdSet -> IO ()
-
-fdSet :: Fd -> Ptr CFdSet -> IO ()
-fdSet (Fd fd) fdset = c_fdSet fd fdset
-
-foreign import ccall unsafe "hsFD_ZERO"
- fdZero :: Ptr CFdSet -> IO ()
-
-foreign import ccall unsafe "sizeof_fd_set"
- sizeofFdSet :: Int
-