Ticket #635: base.diff

File base.diff, 15.0 KB (added by bos, 6 years ago)

base.diff

  • configure.ac

    diff -rN -u old-base/configure.ac new-base/configure.ac
    old new  
    1717AC_HEADER_STDC
    1818
    1919# check for specific header (.h) files that we are interested in
    20 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])
     20AC_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])
    2121
    2222# Enable large file support. Do this before testing the types ino_t, off_t, and
    2323# rlim_t, because it will affect the result of that test.
  • GHC/Conc.lhs

    diff -rN -u old-base/GHC/Conc.lhs new-base/GHC/Conc.lhs
    old new  
    2222-- higher level modules be the home.  Hence:
    2323
    2424#include "Typeable.h"
     25#include "HsBaseConfig.h"
     26
     27#if HAVE_POLL_H
     28# define USE_POLL 1
     29#endif
    2530
    2631-- #not-home
    2732module GHC.Conc
     
    747752-- and delays (threadDelay). 
    748753--
    749754-- We can do this because in the threaded RTS the IO Manager can make
    750 -- a non-blocking call to select(), so we don't have to do select() in
     755-- a non-blocking poll call, so we don't have to poll in
    751756-- the scheduler as we have to in the non-threaded RTS.  We get performance
    752 -- benefits from doing it this way, because we only have to restart the select()
    753 -- when a new request arrives, rather than doing one select() each time
     757-- benefits from doing it this way, because we only have to restart the poll
     758-- when a new request arrives, rather than doing one poll each time
    754759-- around the scheduler loop.  Furthermore, the scheduler can be simplified
    755760-- by not having to check for completed IO requests.
    756761
     
    985990
    986991#else
    987992-- ----------------------------------------------------------------------------
    988 -- Unix IO manager thread, using select()
     993-- Unix IO manager thread
     994
     995data EventType = ReadEvent
     996               | WriteEvent
     997
     998class EventManager e where
     999    resetEventManager :: e -> IO ()
     1000    registerFd :: e -> EventType -> Fd -> IO ()
     1001    isFdReady :: e -> EventType -> Fd -> IO CInt
     1002    pollForEvents :: e -> Ptr CTimeVal -> IO CInt
     1003
     1004#if USE_POLL
     1005
     1006data PollManager = PollManager {
     1007      pollFds :: !(ForeignPtr CPollFd)
     1008    }
     1009
     1010newPollManager :: IO PollManager
     1011newPollManager = do
     1012  pfd <- newForeignPtr finalizerFree =<< c_pollfd_resize nullPtr
     1013  return PollManager { pollFds = pfd }
     1014
     1015instance EventManager PollManager where
     1016    resetEventManager mgr = withForeignPtr (pollFds mgr) c_pollfd_reset
     1017
     1018    registerFd mgr ReadEvent fd = do
     1019      withForeignPtr (pollFds mgr) $ \p -> c_pollfd_add p fd pollReadEvent
     1020    registerFd mgr WriteEvent fd = do
     1021      withForeignPtr (pollFds mgr) $ \p -> c_pollfd_add p fd pollWriteEvent
     1022
     1023    isFdReady mgr ReadEvent fd =
     1024      withForeignPtr (pollFds mgr) $ \p -> c_pollfd_test p fd pollReadEvent
     1025    isFdReady mgr WriteEvent fd =
     1026      withForeignPtr (pollFds mgr) $ \p -> c_pollfd_test p fd pollWriteEvent
     1027
     1028    pollForEvents mgr timeout =
     1029      withForeignPtr (pollFds mgr) $ \p -> c_poll p timeout
     1030
     1031newEventManager = newPollManager
     1032
     1033#else
     1034
     1035data SelectManager = SelectManager {
     1036      selReadFds :: !(ForeignPtr CFdSet)
     1037    , selWriteFds :: !(ForeignPtr CFdSet)
     1038    , selMaxFd :: !(IORef Fd)
     1039    }
     1040
     1041newSelectManager :: IO SelectManager
     1042newSelectManager = do
     1043  rfds <- newForeignPtr finalizerFree =<< mallocBytes sizeofFdSet
     1044  wfds <- newForeignPtr finalizerFree =<< mallocBytes sizeofFdSet
     1045  mfd <- newIORef (-1)
     1046  return SelectManager { selReadFds = rfds
     1047                       , selWriteFds = wfds
     1048                       , selMaxFd = mfd }
     1049
     1050updateMaxFd :: SelectManager -> Fd -> IO ()
     1051updateMaxFd mgr fd = do
     1052  oldMax <- readIORef (selMaxFd mgr)
     1053  when (fd > oldMax) $
     1054    writeIORef (selMaxFd mgr) fd
     1055
     1056instance EventManager SelectManager where
     1057    resetEventManager mgr = do
     1058      withForeignPtr (selReadFds mgr) fdZero
     1059      withForeignPtr (selWriteFds mgr) fdZero
     1060      writeIORef (selMaxFd mgr) (-1)
     1061
     1062    registerFd _ _ fd | fd >= fD_SETSIZE =
     1063        error "registerFd: file descriptor out of range"
     1064    registerFd mgr ReadEvent fd = do
     1065        withForeignPtr (selReadFds mgr) $ fdSet fd
     1066        updateMaxFd mgr fd
     1067    registerFd mgr WriteEvent fd = do
     1068        withForeignPtr (selWriteFds mgr) $ fdSet fd
     1069        updateMaxFd mgr fd
     1070
     1071    isFdReady mgr ReadEvent fd =
     1072        withForeignPtr (selReadFds mgr) $ fdIsSet fd
     1073    isFdReady mgr WriteEvent fd =
     1074        withForeignPtr (selWriteFds mgr) $ fdIsSet fd
     1075
     1076    pollForEvents mgr timeout =
     1077        withForeignPtr (selReadFds mgr) $ \readFds ->
     1078          withForeignPtr (selWriteFds mgr) $ \writeFds -> do
     1079            maxFd <- readIORef (selMaxFd mgr)
     1080            let numFds = fromIntegral maxFd + 1
     1081            c_select numFds readFds writeFds nullPtr timeout
     1082
     1083newEventManager = newSelectManager
     1084
     1085#endif
    9891086
    9901087ioManager :: IO ()
    9911088ioManager = do
     
    9981095        setCloseOnExec rd_end
    9991096        setCloseOnExec wr_end
    10001097        c_setIOManagerPipe wr_end
    1001         allocaBytes sizeofFdSet   $ \readfds -> do
    1002         allocaBytes sizeofFdSet   $ \writefds -> do
     1098        mgr <- newEventManager
    10031099        allocaBytes sizeofTimeVal $ \timeval -> do
    1004         service_loop (fromIntegral rd_end) readfds writefds timeval [] []
     1100        service_loop (fromIntegral rd_end) mgr timeval [] []
    10051101        return ()
    10061102
    10071103service_loop
    1008    :: Fd                -- listen to this for wakeup calls
    1009    -> Ptr CFdSet
    1010    -> Ptr CFdSet
     1104   :: EventManager mgr =>
     1105      Fd                -- listen to this for wakeup calls
     1106   -> mgr
    10111107   -> Ptr CTimeVal
    10121108   -> [IOReq]
    10131109   -> [DelayReq]
    10141110   -> IO ()
    1015 service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
     1111service_loop wakeup mgr ptimeval old_reqs old_delays = do
    10161112
    10171113  -- pick up new IO requests
    10181114  new_reqs <- atomicModifyIORef pendingEvents (\a -> ([],a))
     
    10221118  new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
    10231119  let  delays0 = foldr insertDelay old_delays new_delays
    10241120
    1025   -- build the FDSets for select()
    1026   fdZero readfds
    1027   fdZero writefds
    1028   fdSet wakeup readfds
    1029   maxfd <- buildFdSets 0 readfds writefds reqs
     1121  -- build the event info
     1122  resetEventManager mgr
     1123  registerFd mgr ReadEvent wakeup
     1124  buildEvents mgr reqs
    10301125
    1031   -- perform the select()
    1032   let do_select delays = do
     1126  -- perform the poll
     1127  let do_poll delays = do
    10331128          -- check the current time and wake up any thread in
    10341129          -- threadDelay whose timeout has expired.  Also find the
    1035           -- timeout value for the select() call.
     1130          -- timeout value for the poll.
    10361131          now <- getUSecOfDay
    10371132          (delays', timeout) <- getDelay now ptimeval delays
    10381133
    1039           res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds
    1040                         nullPtr timeout
     1134          res <- pollForEvents mgr timeout
    10411135          if (res == -1)
    10421136             then do
    10431137                err <- getErrno
    10441138                case err of
    1045                   _ | err == eINTR ->  do_select delays'
    1046                         -- EINTR: just redo the select()
     1139                  _ | err == eINTR ->  do_poll delays'
     1140                        -- EINTR: just redo the poll
    10471141                  _ | err == eBADF ->  return (True, delays)
    10481142                        -- EBADF: one of the file descriptors is closed or bad,
    10491143                        -- we don't know which one, so wake everyone up.
    1050                   _ | otherwise    ->  throwErrno "select"
     1144                  _ | otherwise    ->  throwErrno "poll"
    10511145                        -- otherwise (ENOMEM or EINVAL) something has gone
    10521146                        -- wrong; report the error.
    10531147             else
    10541148                return (False,delays')
    10551149
    1056   (wakeup_all,delays') <- do_select delays0
     1150  (wakeup_all,delays') <- do_poll delays0
    10571151
    10581152  exit <-
    10591153    if wakeup_all then return False
    10601154      else do
    1061         b <- fdIsSet wakeup readfds
     1155        b <- isFdReady mgr ReadEvent wakeup
    10621156        if b == 0
    10631157          then return False
    10641158          else alloca $ \p -> do
     
    10871181  atomicModifyIORef prodding (\_ -> (False, ()))
    10881182
    10891183  reqs' <- if wakeup_all then do wakeupAll reqs; return []
    1090                          else completeRequests reqs readfds writefds []
     1184                         else completeRequests reqs mgr []
    10911185
    1092   service_loop wakeup readfds writefds ptimeval reqs' delays'
     1186  service_loop wakeup mgr ptimeval reqs' delays'
    10931187
    10941188io_MANAGER_WAKEUP, io_MANAGER_DIE, io_MANAGER_SYNC :: Word8
    10951189io_MANAGER_WAKEUP = 0xff
     
    11811275-- -----------------------------------------------------------------------------
    11821276-- IO requests
    11831277
    1184 buildFdSets :: Fd -> Ptr CFdSet -> Ptr CFdSet -> [IOReq] -> IO Fd
    1185 buildFdSets maxfd _       _        [] = return maxfd
    1186 buildFdSets maxfd readfds writefds (Read fd _ : reqs)
    1187   | fd >= fD_SETSIZE =  error "buildFdSets: file descriptor out of range"
    1188   | otherwise        =  do
    1189         fdSet fd readfds
    1190         buildFdSets (max maxfd fd) readfds writefds reqs
    1191 buildFdSets maxfd readfds writefds (Write fd _ : reqs)
    1192   | fd >= fD_SETSIZE =  error "buildFdSets: file descriptor out of range"
    1193   | otherwise        =  do
    1194         fdSet fd writefds
    1195         buildFdSets (max maxfd fd) readfds writefds reqs
     1278buildEvents :: EventManager mgr => mgr -> [IOReq] -> IO ()
     1279buildEvents _ [] = return ()
     1280buildEvents mgr (Read fd _ : reqs) = do
     1281  registerFd mgr ReadEvent fd
     1282  buildEvents mgr reqs
     1283buildEvents mgr (Write fd _ : reqs) = do
     1284  registerFd mgr WriteEvent fd
     1285  buildEvents mgr reqs
    11961286
    1197 completeRequests :: [IOReq] -> Ptr CFdSet -> Ptr CFdSet -> [IOReq]
     1287completeRequests :: EventManager mgr => [IOReq] -> mgr -> [IOReq]
    11981288                 -> IO [IOReq]
    1199 completeRequests [] _ _ reqs' = return reqs'
    1200 completeRequests (Read fd m : reqs) readfds writefds reqs' = do
    1201   b <- fdIsSet fd readfds
     1289completeRequests [] _ reqs' = return reqs'
     1290completeRequests (Read fd m : reqs) mgr reqs' = do
     1291  b <- isFdReady mgr ReadEvent fd
    12021292  if b /= 0
    1203     then do putMVar m (); completeRequests reqs readfds writefds reqs'
    1204     else completeRequests reqs readfds writefds (Read fd m : reqs')
    1205 completeRequests (Write fd m : reqs) readfds writefds reqs' = do
    1206   b <- fdIsSet fd writefds
     1293    then do putMVar m (); completeRequests reqs mgr reqs'
     1294    else completeRequests reqs mgr (Read fd m : reqs')
     1295completeRequests (Write fd m : reqs) mgr reqs' = do
     1296  b <- isFdReady mgr WriteEvent fd
    12071297  if b /= 0
    1208     then do putMVar m (); completeRequests reqs readfds writefds reqs'
    1209     else completeRequests reqs readfds writefds (Write fd m : reqs')
     1298    then do putMVar m (); completeRequests reqs mgr reqs'
     1299    else completeRequests reqs mgr (Write fd m : reqs')
    12101300
    12111301wakeupAll :: [IOReq] -> IO ()
    12121302wakeupAll [] = return ()
     
    12621352-}
    12631353
    12641354-- ----------------------------------------------------------------------------
     1355#if USE_POLL
     1356-- poll() interface
     1357
     1358data CPollFd
     1359
     1360foreign import ccall unsafe "__hscore_read_event" c_poll_read_event :: CInt
     1361foreign import ccall unsafe "__hscore_write_event" c_poll_write_event :: CInt
     1362foreign import ccall unsafe "__hscore_pollfd_resize"
     1363  c_pollfd_resize :: Ptr CPollFd -> IO (Ptr CPollFd)
     1364foreign import ccall unsafe "__hscore_pollfd_add"
     1365  c_pollfd_add :: Ptr CPollFd -> Fd -> CInt -> IO ()
     1366foreign import ccall unsafe "__hscore_pollfd_test"
     1367  c_pollfd_test :: Ptr CPollFd -> Fd -> CInt -> IO CInt
     1368foreign import ccall unsafe "__hscore_pollfd_reset"
     1369  c_pollfd_reset :: Ptr CPollFd -> IO ()
     1370foreign import ccall safe "__hscore_poll"
     1371  c_poll :: Ptr CPollFd -> Ptr CTimeVal -> IO CInt
     1372
     1373pollReadEvent, pollWriteEvent :: CInt
     1374pollReadEvent = c_poll_read_event
     1375pollWriteEvent = c_poll_write_event
     1376
     1377#else
    12651378-- select() interface
    12661379
    12671380-- ToDo: move to System.Posix.Internals?
     
    12951408
    12961409foreign import ccall unsafe "sizeof_fd_set"
    12971410  sizeofFdSet :: Int
     1411#endif
    12981412
    12991413#endif
    13001414
  • include/HsBase.h

    diff -rN -u old-base/include/HsBase.h new-base/include/HsBase.h
    old new  
    141141#include <share.h>
    142142#endif
    143143
     144#if HAVE_POLL_H
     145#include <poll.h>
     146#endif
    144147#if HAVE_SYS_SELECT_H
    145148#include <sys/select.h>
    146149#endif
     
    626629
    627630INLINE int __hscore_select(int nfds, fd_set *readfds, fd_set *writefds,
    628631                           fd_set *exceptfds, struct timeval *timeout) {
    629         return (select(nfds,readfds,writefds,exceptfds,timeout));
     632    return select(nfds,readfds,writefds,exceptfds,timeout);
     633}
     634
     635#if HAVE_POLL_H
     636/* Poll-related stuff.  The data structures managed here are assumed
     637   to be accessed only from the I/O manager thread. */
     638
     639typedef struct {
     640    int numfds;                 /* number of array elements allocated */
     641    int lastidx;                /* highest array slot currently in use */
     642    struct pollfd *fds;         /* allocated contiguously at end of struct */
     643} hscore_pollfd;
     644
     645INLINE hscore_pollfd *__hscore_pollfd_resize(hscore_pollfd *o)
     646{
     647    hscore_pollfd *p;
     648    int numfds = o == NULL ? 32 : (o->numfds * 2);
     649    p = realloc(o, sizeof(*p) + numfds * sizeof(p->fds[0]));
     650    if (p == NULL)
     651        abort();
     652    p->numfds = numfds;
     653    p->fds = (struct pollfd *) ((char *)p) + sizeof(*p);
     654    if (o == NULL)
     655        p->lastidx = -1;
     656    return p;
    630657}
    631658
     659/* These may be ORed together into a bitmask. */
     660INLINE int __hscore_read_event()  { return 0x01; }
     661INLINE int __hscore_write_event() { return 0x02; }
     662
     663INLINE void __hscore_pollfd_add(hscore_pollfd *p, int fd, int evt)
     664{
     665    int i;
     666
     667    for (i = 0; i <= p->lastidx && p->fds[i].fd != fd; i++)
     668        ;
     669
     670    if (i > p->lastidx) {
     671        p->lastidx += 1;
     672        if (p->lastidx == p->numfds)
     673            p = __hscore_pollfd_resize(p);
     674        p->fds[i].events = 0;
     675        p->fds[i].fd = fd;
     676    }
     677
     678    if (evt & __hscore_read_event()) {
     679        p->fds[i].events |= POLLIN | POLLPRI;
     680#ifdef POLLRDHUP
     681        p->fds[i].events |= POLLRDHUP;
     682#endif
     683    }
     684    if (evt & __hscore_write_event())
     685        p->fds[i].events |= POLLOUT;
     686}
     687
     688INLINE int __hscore_pollfd_test(hscore_pollfd *p, int fd, int evt)
     689{
     690    int i, r;
     691    int top;
     692
     693    for (i = 0; i <= p->lastidx && p->fds[i].fd != fd; i++)
     694        ;
     695
     696    if (i > p->lastidx)
     697        return 0;
     698
     699    r = p->fds[i].revents & (POLLERR | POLLHUP | POLLNVAL);
     700    if (evt & __hscore_read_event()) {
     701        r |= p->fds[i].revents & (POLLIN | POLLPRI);
     702#ifdef POLLRDHUP
     703        r |= p->fds[i].revents & POLLRDHUP;
     704#endif
     705    }
     706    if (evt & __hscore_write_event())
     707        r |= p->fds[i].revents & POLLOUT;
     708    return r;
     709}
     710
     711INLINE void __hscore_pollfd_reset(hscore_pollfd *p)
     712{
     713    p->lastidx = -1;
     714}
     715
     716INLINE int __hscore_poll(hscore_pollfd *p, struct timeval *timeout)
     717{
     718    int timeo = timeout == NULL
     719      ? -1
     720      : (timeout->tv_sec * 1000 + timeout->tv_usec / 1000);
     721
     722    return poll(p->fds, p->lastidx + 1, timeo);
     723}
     724#endif
     725
    632726// gettimeofday()-related
    633727
    634728#if !defined(__MINGW32__)