Ticket #635: base.diff

configure.ac

@@ -17 +17 @@
 AC_HEADER_STDC
 
 # check for specific header (.h) files that we are interested in
-AC_CHECK_HEADERS([ctype.h errno.h fcntl.h inttypes.h limits.h signal.h sys/resource.h sys/select.h sys/stat.h sys/syscall.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/types.h sys/utsname.h sys/wait.h termios.h time.h unistd.h utime.h windows.h winsock.h langinfo.h])
+AC_CHECK_HEADERS([ctype.h errno.h fcntl.h inttypes.h limits.h poll.h signal.h sys/resource.h sys/select.h sys/stat.h sys/syscall.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/types.h sys/utsname.h sys/wait.h termios.h time.h unistd.h utime.h windows.h winsock.h langinfo.h])
 
 # Enable large file support. Do this before testing the types ino_t, off_t, and
 # rlim_t, because it will affect the result of that test.

GHC/Conc.lhs

@@ -22 +22 @@
 -- higher level modules be the home.  Hence:
 
 #include "Typeable.h"
+#include "HsBaseConfig.h"
+
+#if HAVE_POLL_H
+# define USE_POLL 1
+#endif
 
 -- #not-home
 module GHC.Conc
@@ -747 +752 @@
 -- 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
+-- a non-blocking poll call, so we don't have to poll 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
+-- benefits from doing it this way, because we only have to restart the poll
+-- when a new request arrives, rather than doing one poll each time
 -- around the scheduler loop.  Furthermore, the scheduler can be simplified
 -- by not having to check for completed IO requests.
 
@@ -985 +990 @@
 
 #else
 -- ----------------------------------------------------------------------------
--- Unix IO manager thread, using select()
+-- Unix IO manager thread
+
+data EventType = ReadEvent
+               | WriteEvent
+
+class EventManager e where
+    resetEventManager :: e -> IO ()
+    registerFd :: e -> EventType -> Fd -> IO ()
+    isFdReady :: e -> EventType -> Fd -> IO CInt
+    pollForEvents :: e -> Ptr CTimeVal -> IO CInt
+
+#if USE_POLL
+
+data PollManager = PollManager {
+      pollFds :: !(ForeignPtr CPollFd)
+    }
+
+newPollManager :: IO PollManager
+newPollManager = do
+  pfd <- newForeignPtr finalizerFree =<< c_pollfd_resize nullPtr
+  return PollManager { pollFds = pfd }
+
+instance EventManager PollManager where
+    resetEventManager mgr = withForeignPtr (pollFds mgr) c_pollfd_reset
+
+    registerFd mgr ReadEvent fd = do
+      withForeignPtr (pollFds mgr) $ \p -> c_pollfd_add p fd pollReadEvent
+    registerFd mgr WriteEvent fd = do
+      withForeignPtr (pollFds mgr) $ \p -> c_pollfd_add p fd pollWriteEvent
+
+    isFdReady mgr ReadEvent fd =
+      withForeignPtr (pollFds mgr) $ \p -> c_pollfd_test p fd pollReadEvent
+    isFdReady mgr WriteEvent fd =
+      withForeignPtr (pollFds mgr) $ \p -> c_pollfd_test p fd pollWriteEvent
+
+    pollForEvents mgr timeout =
+      withForeignPtr (pollFds mgr) $ \p -> c_poll p timeout
+
+newEventManager = newPollManager
+
+#else
+
+data SelectManager = SelectManager {
+      selReadFds :: !(ForeignPtr CFdSet)
+    , selWriteFds :: !(ForeignPtr CFdSet)
+    , selMaxFd :: !(IORef Fd)
+    }
+
+newSelectManager :: IO SelectManager
+newSelectManager = do
+  rfds <- newForeignPtr finalizerFree =<< mallocBytes sizeofFdSet
+  wfds <- newForeignPtr finalizerFree =<< mallocBytes sizeofFdSet
+  mfd <- newIORef (-1)
+  return SelectManager { selReadFds = rfds
+                       , selWriteFds = wfds
+                       , selMaxFd = mfd }
+
+updateMaxFd :: SelectManager -> Fd -> IO ()
+updateMaxFd mgr fd = do
+  oldMax <- readIORef (selMaxFd mgr)
+  when (fd > oldMax) $
+    writeIORef (selMaxFd mgr) fd
+
+instance EventManager SelectManager where
+    resetEventManager mgr = do
+      withForeignPtr (selReadFds mgr) fdZero
+      withForeignPtr (selWriteFds mgr) fdZero
+      writeIORef (selMaxFd mgr) (-1)
+
+    registerFd _ _ fd | fd >= fD_SETSIZE =
+        error "registerFd: file descriptor out of range"
+    registerFd mgr ReadEvent fd = do
+        withForeignPtr (selReadFds mgr) $ fdSet fd
+        updateMaxFd mgr fd
+    registerFd mgr WriteEvent fd = do
+        withForeignPtr (selWriteFds mgr) $ fdSet fd
+        updateMaxFd mgr fd
+
+    isFdReady mgr ReadEvent fd =
+        withForeignPtr (selReadFds mgr) $ fdIsSet fd
+    isFdReady mgr WriteEvent fd =
+        withForeignPtr (selWriteFds mgr) $ fdIsSet fd
+
+    pollForEvents mgr timeout =
+        withForeignPtr (selReadFds mgr) $ \readFds ->
+          withForeignPtr (selWriteFds mgr) $ \writeFds -> do
+            maxFd <- readIORef (selMaxFd mgr)
+            let numFds = fromIntegral maxFd + 1
+            c_select numFds readFds writeFds nullPtr timeout
+
+newEventManager = newSelectManager
+
+#endif
 
 ioManager :: IO ()
 ioManager = do
@@ -998 +1095 @@
         setCloseOnExec rd_end
         setCloseOnExec wr_end
         c_setIOManagerPipe wr_end
-        allocaBytes sizeofFdSet   $ \readfds -> do
-        allocaBytes sizeofFdSet   $ \writefds -> do 
+        mgr <- newEventManager
         allocaBytes sizeofTimeVal $ \timeval -> do
-        service_loop (fromIntegral rd_end) readfds writefds timeval [] []
+        service_loop (fromIntegral rd_end) mgr timeval [] []
         return ()
 
 service_loop
-   :: Fd                -- listen to this for wakeup calls
-   -> Ptr CFdSet
-   -> Ptr CFdSet
+   :: EventManager mgr =>
+      Fd                -- listen to this for wakeup calls
+   -> mgr
    -> Ptr CTimeVal
    -> [IOReq]
    -> [DelayReq]
    -> IO ()
-service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
+service_loop wakeup mgr ptimeval old_reqs old_delays = do
 
   -- pick up new IO requests
   new_reqs <- atomicModifyIORef pendingEvents (\a -> ([],a))
@@ -1022 +1118 @@
   new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
   let  delays0 = foldr insertDelay old_delays new_delays
 
-  -- build the FDSets for select()
-  fdZero readfds
-  fdZero writefds
-  fdSet wakeup readfds
-  maxfd <- buildFdSets 0 readfds writefds reqs
+  -- build the event info
+  resetEventManager mgr
+  registerFd mgr ReadEvent wakeup
+  buildEvents mgr reqs
 
-  -- perform the select()
-  let do_select delays = do
+  -- perform the poll
+  let do_poll 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.
+          -- timeout value for the poll.
           now <- getUSecOfDay
           (delays', timeout) <- getDelay now ptimeval delays
 
-          res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds 
-                        nullPtr timeout
+          res <- pollForEvents mgr timeout
           if (res == -1)
              then do
                 err <- getErrno
                 case err of
-                  _ | err == eINTR ->  do_select delays'
-                        -- EINTR: just redo the select()
+                  _ | err == eINTR ->  do_poll delays'
+                        -- EINTR: just redo the poll
                   _ | 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    ->  throwErrno "poll"
                         -- otherwise (ENOMEM or EINVAL) something has gone
                         -- wrong; report the error.
              else
                 return (False,delays')
 
-  (wakeup_all,delays') <- do_select delays0
+  (wakeup_all,delays') <- do_poll delays0
 
   exit <-
     if wakeup_all then return False
       else do
-        b <- fdIsSet wakeup readfds
+        b <- isFdReady mgr ReadEvent wakeup
         if b == 0 
           then return False
           else alloca $ \p -> do 
@@ -1087 +1181 @@
   atomicModifyIORef prodding (\_ -> (False, ()))
 
   reqs' <- if wakeup_all then do wakeupAll reqs; return []
-                         else completeRequests reqs readfds writefds []
+                         else completeRequests reqs mgr []
 
-  service_loop wakeup readfds writefds ptimeval reqs' delays'
+  service_loop wakeup mgr ptimeval reqs' delays'
 
 io_MANAGER_WAKEUP, io_MANAGER_DIE, io_MANAGER_SYNC :: Word8
 io_MANAGER_WAKEUP = 0xff
@@ -1181 +1275 @@
 -- -----------------------------------------------------------------------------
 -- IO requests
 
-buildFdSets :: Fd -> Ptr CFdSet -> Ptr CFdSet -> [IOReq] -> IO Fd
-buildFdSets maxfd _       _        [] = return maxfd
-buildFdSets maxfd readfds writefds (Read fd _ : 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 _ : reqs)
-  | fd >= fD_SETSIZE =  error "buildFdSets: file descriptor out of range"
-  | otherwise        =  do
-        fdSet fd writefds
-        buildFdSets (max maxfd fd) readfds writefds reqs
+buildEvents :: EventManager mgr => mgr -> [IOReq] -> IO ()
+buildEvents _ [] = return ()
+buildEvents mgr (Read fd _ : reqs) = do
+  registerFd mgr ReadEvent fd
+  buildEvents mgr reqs
+buildEvents mgr (Write fd _ : reqs) = do
+  registerFd mgr WriteEvent fd
+  buildEvents mgr reqs
 
-completeRequests :: [IOReq] -> Ptr CFdSet -> Ptr CFdSet -> [IOReq]
+completeRequests :: EventManager mgr => [IOReq] -> mgr -> [IOReq]
                  -> IO [IOReq]
-completeRequests [] _ _ reqs' = return reqs'
-completeRequests (Read fd m : reqs) readfds writefds reqs' = do
-  b <- fdIsSet fd readfds
+completeRequests [] _ reqs' = return reqs'
+completeRequests (Read fd m : reqs) mgr reqs' = do
+  b <- isFdReady mgr ReadEvent fd
   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
+    then do putMVar m (); completeRequests reqs mgr reqs'
+    else completeRequests reqs mgr (Read fd m : reqs')
+completeRequests (Write fd m : reqs) mgr reqs' = do
+  b <- isFdReady mgr WriteEvent fd
   if b /= 0
-    then do putMVar m (); completeRequests reqs readfds writefds reqs'
-    else completeRequests reqs readfds writefds (Write fd m : reqs')
+    then do putMVar m (); completeRequests reqs mgr reqs'
+    else completeRequests reqs mgr (Write fd m : reqs')
 
 wakeupAll :: [IOReq] -> IO ()
 wakeupAll [] = return ()
@@ -1262 +1352 @@
 -}
 
 -- ----------------------------------------------------------------------------
+#if USE_POLL
+-- poll() interface
+
+data CPollFd
+
+foreign import ccall unsafe "__hscore_read_event" c_poll_read_event :: CInt
+foreign import ccall unsafe "__hscore_write_event" c_poll_write_event :: CInt
+foreign import ccall unsafe "__hscore_pollfd_resize"
+  c_pollfd_resize :: Ptr CPollFd -> IO (Ptr CPollFd)
+foreign import ccall unsafe "__hscore_pollfd_add"
+  c_pollfd_add :: Ptr CPollFd -> Fd -> CInt -> IO ()
+foreign import ccall unsafe "__hscore_pollfd_test"
+  c_pollfd_test :: Ptr CPollFd -> Fd -> CInt -> IO CInt
+foreign import ccall unsafe "__hscore_pollfd_reset"
+  c_pollfd_reset :: Ptr CPollFd -> IO ()
+foreign import ccall safe "__hscore_poll"
+  c_poll :: Ptr CPollFd -> Ptr CTimeVal -> IO CInt
+
+pollReadEvent, pollWriteEvent :: CInt
+pollReadEvent = c_poll_read_event
+pollWriteEvent = c_poll_write_event
+
+#else
 -- select() interface
 
 -- ToDo: move to System.Posix.Internals?
@@ -1295 +1408 @@
 
 foreign import ccall unsafe "sizeof_fd_set"
   sizeofFdSet :: Int
+#endif
 
 #endif
 

include/HsBase.h

@@ -141 +141 @@
 #include <share.h>
 #endif
 
+#if HAVE_POLL_H
+#include <poll.h>
+#endif
 #if HAVE_SYS_SELECT_H
 #include <sys/select.h>
 #endif
@@ -626 +629 @@
 
 INLINE int __hscore_select(int nfds, fd_set *readfds, fd_set *writefds,
                            fd_set *exceptfds, struct timeval *timeout) {
-        return (select(nfds,readfds,writefds,exceptfds,timeout));
+    return select(nfds,readfds,writefds,exceptfds,timeout);
+}
+
+#if HAVE_POLL_H
+/* Poll-related stuff.  The data structures managed here are assumed
+   to be accessed only from the I/O manager thread. */
+
+typedef struct {
+    int numfds;                 /* number of array elements allocated */
+    int lastidx;                /* highest array slot currently in use */
+    struct pollfd *fds;         /* allocated contiguously at end of struct */
+} hscore_pollfd;
+
+INLINE hscore_pollfd *__hscore_pollfd_resize(hscore_pollfd *o)
+{
+    hscore_pollfd *p;
+    int numfds = o == NULL ? 32 : (o->numfds * 2);
+    p = realloc(o, sizeof(*p) + numfds * sizeof(p->fds[0]));
+    if (p == NULL)
+        abort();
+    p->numfds = numfds;
+    p->fds = (struct pollfd *) ((char *)p) + sizeof(*p);
+    if (o == NULL)
+        p->lastidx = -1;
+    return p;
 }
 
+/* These may be ORed together into a bitmask. */
+INLINE int __hscore_read_event()  { return 0x01; }
+INLINE int __hscore_write_event() { return 0x02; }
+
+INLINE void __hscore_pollfd_add(hscore_pollfd *p, int fd, int evt)
+{
+    int i;
+
+    for (i = 0; i <= p->lastidx && p->fds[i].fd != fd; i++)
+        ;
+
+    if (i > p->lastidx) {
+        p->lastidx += 1;
+        if (p->lastidx == p->numfds)
+            p = __hscore_pollfd_resize(p);
+        p->fds[i].events = 0;
+        p->fds[i].fd = fd;
+    }
+
+    if (evt & __hscore_read_event()) {
+        p->fds[i].events |= POLLIN | POLLPRI;
+#ifdef POLLRDHUP
+        p->fds[i].events |= POLLRDHUP;
+#endif
+    }
+    if (evt & __hscore_write_event())
+        p->fds[i].events |= POLLOUT;
+}
+
+INLINE int __hscore_pollfd_test(hscore_pollfd *p, int fd, int evt)
+{
+    int i, r;
+    int top;
+
+    for (i = 0; i <= p->lastidx && p->fds[i].fd != fd; i++)
+        ;
+
+    if (i > p->lastidx)
+        return 0;
+
+    r = p->fds[i].revents & (POLLERR | POLLHUP | POLLNVAL);
+    if (evt & __hscore_read_event()) {
+        r |= p->fds[i].revents & (POLLIN | POLLPRI);
+#ifdef POLLRDHUP
+        r |= p->fds[i].revents & POLLRDHUP;
+#endif
+    }
+    if (evt & __hscore_write_event())
+        r |= p->fds[i].revents & POLLOUT;
+    return r;
+}
+
+INLINE void __hscore_pollfd_reset(hscore_pollfd *p)
+{
+    p->lastidx = -1;
+}
+
+INLINE int __hscore_poll(hscore_pollfd *p, struct timeval *timeout)
+{
+    int timeo = timeout == NULL
+      ? -1
+      : (timeout->tv_sec * 1000 + timeout->tv_usec / 1000);
+
+    return poll(p->fds, p->lastidx + 1, timeo);
+}
+#endif
+
 // gettimeofday()-related
 
 #if !defined(__MINGW32__)