Ticket #635: base.diff

File base.diff, 15.0 KB (added by bos, 4 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__)