Update parallel IO manager to handle the invalid files in the same way as previous...
authorAndreas Voellmy <andreas.voellmy@gmail.com>
Mon, 18 Mar 2013 02:27:49 +0000 (22:27 -0400)
committerAndreas Voellmy <andreas.voellmy@gmail.com>
Mon, 6 May 2013 03:08:37 +0000 (23:08 -0400)
This patch affects the IO manager using kqueue. See issue #7773. If the kqueue backend cannot wait for events on a file, it will simply call the registered callback for the file immediately. This is the behavior of the previous IO manager. This is not ideal, but it is an initial step toward dealing with the problem properly. Ideally, we would use a non-kqueue mechanism for waiting on files (select seems most reliable) that cannot be waited on with kqueue.

Foreign/C/Error.hs
GHC/Event/EPoll.hsc
GHC/Event/Internal.hs
GHC/Event/KQueue.hsc
GHC/Event/Manager.hs
GHC/Event/Poll.hsc
GHC/Event/TimerManager.hs
configure.ac
tests/T7773.hs [new file with mode: 0644]
tests/T7773.stdout [new file with mode: 0644]
tests/all.T

index 4d33262..d2f1580 100644 (file)
@@ -34,7 +34,7 @@ module Foreign.C.Error (
   eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH, 
   eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK, 
   eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS, 
-  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO, 
+  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTSUP, eNOTTY, eNXIO,
   eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL, 
   ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE, 
   eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN, 
@@ -141,7 +141,7 @@ eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,
   eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH, 
   eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK, 
   eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS, 
-  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO, 
+  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTSUP, eNOTTY, eNXIO,
   eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL, 
   ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE, 
   eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN, 
@@ -218,6 +218,7 @@ eNOTCONN        = Errno (CONST_ENOTCONN)
 eNOTDIR         = Errno (CONST_ENOTDIR)
 eNOTEMPTY       = Errno (CONST_ENOTEMPTY)
 eNOTSOCK        = Errno (CONST_ENOTSOCK)
+eNOTSUP         = Errno (CONST_ENOTSUP)
 eNOTTY          = Errno (CONST_ENOTTY)
 eNXIO           = Errno (CONST_ENXIO)
 eOPNOTSUPP      = Errno (CONST_EOPNOTSUPP)
index c7a7662..44c8bd9 100644 (file)
@@ -40,7 +40,7 @@ available = False
 
 #include <sys/epoll.h>
 
-import Control.Monad (unless, when)
+import Control.Monad (when)
 import Data.Bits (Bits, (.|.), (.&.))
 import Data.Maybe (Maybe(..))
 import Data.Monoid (Monoid(..))
@@ -87,24 +87,28 @@ delete be = do
 
 -- | Change the set of events we are interested in for a given file
 -- descriptor.
-modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO ()
-modifyFd ep fd oevt nevt = with (Event (fromEvent nevt) fd) $
-                             epollControl (epollFd ep) op fd
+modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO Bool
+modifyFd ep fd oevt nevt =
+  with (Event (fromEvent nevt) fd) $ \evptr -> do
+    epollControl (epollFd ep) op fd evptr
+    return True
   where op | oevt == mempty = controlOpAdd
            | nevt == mempty = controlOpDelete
            | otherwise      = controlOpModify
 
-modifyFdOnce :: EPoll -> Fd -> E.Event -> IO ()
+modifyFdOnce :: EPoll -> Fd -> E.Event -> IO Bool
 modifyFdOnce ep fd evt =
   do let !ev = fromEvent evt .|. epollOneShot
      res <- with (Event ev fd) $
             epollControl_ (epollFd ep) controlOpModify fd
-     unless (res == 0) $ do
-         err <- getErrno
-         if err == eNOENT then
-             with (Event ev fd) $ epollControl (epollFd ep) controlOpAdd fd
-           else
-             throwErrno "modifyFdOnce"
+     if res == 0
+       then return True
+       else do err <- getErrno
+               if err == eNOENT
+                 then with (Event ev fd) $ \evptr -> do
+                        epollControl (epollFd ep) controlOpAdd fd evptr
+                        return True
+                 else throwErrno "modifyFdOnce"
 
 -- | Select a set of file descriptors which are ready for I/O
 -- operations and call @f@ for all ready file descriptors, passing the
index 7b25c86..a4c2e10 100644 (file)
@@ -102,19 +102,19 @@ data Backend = forall a. Backend {
                   -> Fd       -- file descriptor
                   -> Event    -- old events to watch for ('mempty' for new)
                   -> Event    -- new events to watch for ('mempty' to delete)
-                  -> IO ()
+                  -> IO Bool
 
     , _beModifyFdOnce :: a
                          -> Fd    -- file descriptor
                          -> Event -- new events to watch
-                         -> IO ()
+                         -> IO Bool
 
     , _beDelete :: a -> IO ()
     }
 
 backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
-        -> (a -> Fd -> Event -> Event -> IO ())
-        -> (a -> Fd -> Event -> IO ())
+        -> (a -> Fd -> Event -> Event -> IO Bool)
+        -> (a -> Fd -> Event -> IO Bool)
         -> (a -> IO ())
         -> a
         -> Backend
@@ -126,11 +126,17 @@ poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
 poll (Backend bState bPoll _ _ _) = bPoll bState
 {-# INLINE poll #-}
 
-modifyFd :: Backend -> Fd -> Event -> Event -> IO ()
+-- | Returns 'True' if the modification succeeded.
+-- Returns 'False' if this backend does not support
+-- event notifications on this type of file.
+modifyFd :: Backend -> Fd -> Event -> Event -> IO Bool
 modifyFd (Backend bState _ bModifyFd _ _) = bModifyFd bState
 {-# INLINE modifyFd #-}
 
-modifyFdOnce :: Backend -> Fd -> Event -> IO ()
+-- | Returns 'True' if the modification succeeded.
+-- Returns 'False' if this backend does not support
+-- event notifications on this type of file.
+modifyFdOnce :: Backend -> Fd -> Event -> IO Bool
 modifyFdOnce (Backend bState _ _ bModifyFdOnce _) = bModifyFdOnce bState
 {-# INLINE modifyFdOnce #-}
 
index fc1d679..6fca28a 100644 (file)
@@ -28,12 +28,13 @@ available = False
 {-# INLINE available #-}
 #else
 
-import Control.Monad (when, void)
+import Control.Monad (when)
 import Data.Bits (Bits(..))
 import Data.Maybe (Maybe(..))
 import Data.Monoid (Monoid(..))
 import Data.Word (Word16, Word32)
-import Foreign.C.Error (throwErrnoIfMinus1)
+import Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL,
+                        eNOTSUP, getErrno, throwErrno)
 import Foreign.C.Types
 import Foreign.Marshal.Alloc (alloca)
 import Foreign.Ptr (Ptr, nullPtr)
@@ -88,7 +89,7 @@ delete kq = do
   _ <- c_close . fromKQueueFd . kqueueFd $ kq
   return ()
 
-modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO ()
+modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool
 modifyFd kq fd oevt nevt
   | nevt == mempty = do
       let !ev = event fd (toFilter oevt) flagDelete noteEOF
@@ -102,7 +103,7 @@ toFilter evt
   | evt `E.eventIs` E.evtRead = filterRead
   | otherwise                 = filterWrite
 
-modifyFdOnce :: KQueue -> Fd -> E.Event -> IO ()
+modifyFdOnce :: KQueue -> Fd -> E.Event -> IO Bool
 modifyFdOnce kq fd evt = do
     let !ev = event fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF
     kqueueControl (kqueueFd kq) ev
@@ -224,28 +225,38 @@ instance Storable TimeSpec where
 kqueue :: IO KQueueFd
 kqueue = KQueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue
 
-kqueueControl :: KQueueFd -> Event -> IO ()
-kqueueControl kfd ev = void $
+kqueueControl :: KQueueFd -> Event -> IO Bool
+kqueueControl kfd ev =
     withTimeSpec (TimeSpec 0 0) $ \tp ->
-        withEvent ev $ \evp -> kevent False kfd evp 1 nullPtr 0 tp
+        withEvent ev $ \evp -> do
+            res <- kevent False kfd evp 1 nullPtr 0 tp
+            if res == -1
+              then do
+               err <- getErrno
+               case err of
+                 _ | err == eINTR  -> return True
+                 _ | err == eINVAL -> return False
+                 _ | err == eNOTSUP -> return False
+                 _                 -> throwErrno "kevent"
+              else return True
 
 kqueueWait :: KQueueFd -> Ptr Event -> Int -> TimeSpec -> IO Int
 kqueueWait fd es cap tm =
+    fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
     withTimeSpec tm $ kevent True fd nullPtr 0 es cap
 
 kqueueWaitNonBlock :: KQueueFd -> Ptr Event -> Int -> IO Int
 kqueueWaitNonBlock fd es cap =
+    fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
     withTimeSpec (TimeSpec 0 0) $ kevent False fd nullPtr 0 es cap
 
 -- TODO: We cannot retry on EINTR as the timeout would be wrong.
 -- Perhaps we should just return without calling any callbacks.
 kevent :: Bool -> KQueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
-       -> IO Int
+       -> IO CInt
 kevent safe k chs chlen evs evlen ts
-    = fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
-      if safe 
-      then c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
-      else c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
+  | safe      = c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
+  | otherwise = c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
 
 withEvent :: Event -> (Ptr Event -> IO a) -> IO a
 withEvent ev f = alloca $ \ptr -> poke ptr ev >> f ptr
index 1dd9cc1..16ca53a 100644 (file)
@@ -193,8 +193,18 @@ newWith oneShot be = do
   registerControlFd mgr (wakeupReadFd ctrl) evtRead
   return mgr
 
+failOnInvalidFile :: String -> Fd -> IO Bool -> IO ()
+failOnInvalidFile loc fd m = do
+  ok <- m
+  when (not ok) $
+    let msg = "Failed while attempting to modify registration of file " ++
+              show fd ++ " at location " ++ loc
+    in error msg
+
 registerControlFd :: EventManager -> Fd -> Event -> IO ()
-registerControlFd mgr fd evs = I.modifyFd (emBackend mgr) fd mempty evs
+registerControlFd mgr fd evs =
+  failOnInvalidFile "registerControlFd" fd $
+  I.modifyFd (emBackend mgr) fd mempty evs
 
 -- | Asynchronously shuts down the event manager, if running.
 shutdown :: EventManager -> IO ()
@@ -284,21 +294,31 @@ registerFd_ mgr@(EventManager{..}) cb fd evs = do
   let fd'  = fromIntegral fd
       reg  = FdKey fd u
       !fdd = FdData reg evs cb
-  modifyMVar (callbackTableVar mgr fd) $ \oldMap ->
+  (modify,ok) <- modifyMVar (callbackTableVar mgr fd) $ \oldMap ->
     if haveOneShot && emOneShot
-    then case IM.insertWith (++) fd' [fdd] oldMap of
-      (Nothing,   n) -> do I.modifyFdOnce emBackend fd evs
-                           return (n, (reg, False))
-      (Just prev, n) -> do I.modifyFdOnce emBackend fd (combineEvents evs prev)
-                           return (n, (reg, False))
+    then do let (n,evs') = case IM.insertWith (++) fd' [fdd] oldMap of
+                  (Nothing,   n') -> (n', evs)
+                  (Just prev, n') -> (n', combineEvents evs prev)
+            ok <- I.modifyFdOnce emBackend fd evs'
+            if ok
+              then return (n, (False, True))
+              else return (oldMap, (False, False))
     else
       let (!newMap, (oldEvs, newEvs)) =
             case IM.insertWith (++) fd' [fdd] oldMap of
               (Nothing,   n) -> (n, (mempty, evs))
               (Just prev, n) -> (n, (eventsOf prev, combineEvents evs prev))
           modify = oldEvs /= newEvs
-      in do when modify $ I.modifyFd emBackend fd oldEvs newEvs
-            return (newMap, (reg, modify))
+      in do ok <- if modify
+                  then I.modifyFd emBackend fd oldEvs newEvs
+                  else return True
+            if ok
+              then return (newMap, (modify, True))
+              else return (oldMap, (False, False))
+  -- this simulates behavior of old IO manager:
+  -- i.e. just call the callback if the registration fails.
+  when (not ok) (cb reg evs)
+  return (reg,modify)
 {-# INLINE registerFd_ #-}
 
 combineEvents :: Event -> [FdData] -> Event
@@ -358,7 +378,7 @@ unregisterFd_ mgr@(EventManager{..}) (FdKey fd u) =
               (Nothing,   _)    -> (oldMap, (mempty, mempty))
               (Just prev, newm) -> (newm, pairEvents prev newm fd')
         modify = oldEvs /= newEvs
-    when modify $
+    when modify $ failOnInvalidFile "unregisterFd_" fd $
       if haveOneShot && emOneShot && newEvs /= mempty
       then I.modifyFdOnce emBackend fd newEvs
       else I.modifyFd emBackend fd oldEvs newEvs
@@ -380,7 +400,7 @@ closeFd mgr close fd = do
       (Just fds, !newMap) -> do
         let oldEvs = eventsOf fds
         when (oldEvs /= mempty) $ do
-          I.modifyFd (emBackend mgr) fd oldEvs mempty
+          _ <- I.modifyFd (emBackend mgr) fd oldEvs mempty
           wakeManager mgr
         close fd
         return (newMap, fds)
@@ -400,7 +420,7 @@ closeFd_ mgr oldMap fd = do
     (Just fds, !newMap) -> do
       let oldEvs = eventsOf fds
       when (oldEvs /= mempty) $ do
-        I.modifyFd (emBackend mgr) fd oldEvs mempty
+        _ <- I.modifyFd (emBackend mgr) fd oldEvs mempty
         wakeManager mgr
       let runCbs =
             forM_ fds $ \(FdData reg ev cb) -> cb reg (ev `mappend` evtClose)
@@ -439,16 +459,16 @@ onFdEvent mgr fd evs =
         aux [] _    []          =
           if haveOneShot
           then return (curmap, cbs)
-          else do I.modifyFd (emBackend mgr) fd (eventsOf cbs) mempty
+          else do _ <- I.modifyFd (emBackend mgr) fd (eventsOf cbs) mempty
                   return (curmap, cbs)
 
         -- reinsert and rearm; note that we already have the lock on the
         -- callback table for this fd, and we deleted above, so we know there
         -- is no entry in the table for this fd.
         aux [] fdds saved@(_:_) = do
-          if haveOneShot
-            then I.modifyFdOnce (emBackend mgr) fd $ eventsOf saved
-            else I.modifyFd (emBackend mgr) fd (eventsOf cbs) $ eventsOf saved
+          _ <- if haveOneShot
+               then I.modifyFdOnce (emBackend mgr) fd $ eventsOf saved
+               else I.modifyFd (emBackend mgr) fd (eventsOf cbs) $ eventsOf saved
           return (snd $ IM.insertWith (\_ _ -> saved) fd' saved curmap, fdds)
 
         -- continue, saving those callbacks that don't match the event
index 028a616..c5003ff 100644 (file)
@@ -59,12 +59,13 @@ new :: IO E.Backend
 new = E.backend poll modifyFd modifyFdOnce (\_ -> return ()) `liftM`
       liftM2 Poll (newMVar =<< A.empty) A.empty
 
-modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO ()
+modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO Bool
 modifyFd p fd oevt nevt =
-  withMVar (pollChanges p) $ \ary ->
+  withMVar (pollChanges p) $ \ary -> do
     A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt)
+    return True
 
-modifyFdOnce :: Poll -> Fd -> E.Event -> IO ()
+modifyFdOnce :: Poll -> Fd -> E.Event -> IO Bool
 modifyFdOnce = error "modifyFdOnce not supported in Poll backend"
 
 reworkFd :: Poll -> PollFd -> IO ()
index dd55355..8a519df 100644 (file)
@@ -160,8 +160,8 @@ newWith be = do
                          , emUniqueSource = us
                          , emControl = ctrl
                          }
-  I.modifyFd be (controlReadFd ctrl) mempty evtRead
-  I.modifyFd be (wakeupReadFd ctrl) mempty evtRead
+  _ <- I.modifyFd be (controlReadFd ctrl) mempty evtRead
+  _ <- I.modifyFd be (wakeupReadFd ctrl) mempty evtRead
   return mgr
 
 -- | Asynchronously shuts down the event manager, if running.
index 7553a7a..eff1e02 100644 (file)
@@ -139,7 +139,7 @@ FPTOOLS_CHECK_HTYPE(intmax_t)
 FPTOOLS_CHECK_HTYPE(uintmax_t)
 
 # test errno values
-FP_CHECK_CONSTS([E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EADV EAFNOSUPPORT EAGAIN EALREADY EBADF EBADMSG EBADRPC EBUSY ECHILD ECOMM ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDIRTY EDOM EDQUOT EEXIST EFAULT EFBIG EFTYPE EHOSTDOWN EHOSTUNREACH EIDRM EILSEQ EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE EMULTIHOP ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODATA ENODEV ENOENT ENOEXEC ENOLCK ENOLINK ENOMEM ENOMSG ENONET ENOPROTOOPT ENOSPC ENOSR ENOSTR ENOSYS ENOTBLK ENOTCONN ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE EPROCLIM EPROCUNAVAIL EPROGMISMATCH EPROGUNAVAIL EPROTO EPROTONOSUPPORT EPROTOTYPE ERANGE EREMCHG EREMOTE EROFS ERPCMISMATCH ERREMOTE ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESRMNT ESTALE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV ENOCIGAR], [#include <stdio.h>
+FP_CHECK_CONSTS([E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EADV EAFNOSUPPORT EAGAIN EALREADY EBADF EBADMSG EBADRPC EBUSY ECHILD ECOMM ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDIRTY EDOM EDQUOT EEXIST EFAULT EFBIG EFTYPE EHOSTDOWN EHOSTUNREACH EIDRM EILSEQ EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE EMULTIHOP ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODATA ENODEV ENOENT ENOEXEC ENOLCK ENOLINK ENOMEM ENOMSG ENONET ENOPROTOOPT ENOSPC ENOSR ENOSTR ENOSYS ENOTBLK ENOTCONN ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE EPROCLIM EPROCUNAVAIL EPROGMISMATCH EPROGUNAVAIL EPROTO EPROTONOSUPPORT EPROTOTYPE ERANGE EREMCHG EREMOTE EROFS ERPCMISMATCH ERREMOTE ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESRMNT ESTALE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV ENOCIGAR ENOTSUP], [#include <stdio.h>
 #include <errno.h>])
 
 # we need SIGINT in TopHandler.lhs
diff --git a/tests/T7773.hs b/tests/T7773.hs
new file mode 100644 (file)
index 0000000..495cd7a
--- /dev/null
@@ -0,0 +1,9 @@
+import Control.Concurrent
+import System.Posix.IO
+
+main = do
+  putStrLn "hello"
+  fd <- openFd "/dev/random" ReadOnly Nothing defaultFileFlags
+  threadWaitRead fd
+  putStrLn "goodbye"
+  
\ No newline at end of file
diff --git a/tests/T7773.stdout b/tests/T7773.stdout
new file mode 100644 (file)
index 0000000..a32119c
--- /dev/null
@@ -0,0 +1,2 @@
+hello
+goodbye
index 782d11e..7a56fe6 100644 (file)
@@ -122,3 +122,4 @@ test('qsem001', normal, compile_and_run, [''])
 test('qsemn001', normal, compile_and_run, [''])
 
 test('T7457', normal, compile_and_run, [''])
+test('T7773', normal, compile_and_run, [''])