Ticket #7773: 7773.patch

File 7773.patch, 11.8 KB (added by AndreasVoellmy, 2 years ago)

Patch to make parallel IO manager treat invalid files on queue in the same way as the old IO manager did.

  • GHC/Event/EPoll.hsc

    From cb60092a0f1cfb1d1596d9ed4b9896fb7a27ea7b Mon Sep 17 00:00:00 2001
    From: Andreas Voellmy <[email protected]>
    Date: Sun, 17 Mar 2013 22:27:49 -0400
    Subject: [PATCH] Update parallel IO manager to handle the invalid files in
     the same way as previous IO manager.
    
    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.
    ---
     GHC/Event/EPoll.hsc   | 26 +++++++++++++++-----------
     GHC/Event/Internal.hs | 18 ++++++++++++------
     GHC/Event/KQueue.hsc  | 33 +++++++++++++++++++++------------
     GHC/Event/Manager.hs  | 38 ++++++++++++++++++++++++++++----------
     GHC/Event/Poll.hsc    |  7 ++++---
     5 files changed, 80 insertions(+), 42 deletions(-)
    
    diff --git a/GHC/Event/EPoll.hsc b/GHC/Event/EPoll.hsc
    index c7a7662..44c8bd9 100644
    a b available = False 
    4040
    4141#include <sys/epoll.h>
    4242
    43 import Control.Monad (unless, when)
     43import Control.Monad (when)
    4444import Data.Bits (Bits, (.|.), (.&.))
    4545import Data.Maybe (Maybe(..))
    4646import Data.Monoid (Monoid(..))
    delete be = do 
    8787
    8888-- | Change the set of events we are interested in for a given file
    8989-- descriptor.
    90 modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO ()
    91 modifyFd ep fd oevt nevt = with (Event (fromEvent nevt) fd) $
    92                              epollControl (epollFd ep) op fd
     90modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO Bool
     91modifyFd ep fd oevt nevt =
     92  with (Event (fromEvent nevt) fd) $ \evptr -> do
     93    epollControl (epollFd ep) op fd evptr
     94    return True
    9395  where op | oevt == mempty = controlOpAdd
    9496           | nevt == mempty = controlOpDelete
    9597           | otherwise      = controlOpModify
    9698
    97 modifyFdOnce :: EPoll -> Fd -> E.Event -> IO ()
     99modifyFdOnce :: EPoll -> Fd -> E.Event -> IO Bool
    98100modifyFdOnce ep fd evt =
    99101  do let !ev = fromEvent evt .|. epollOneShot
    100102     res <- with (Event ev fd) $
    101103            epollControl_ (epollFd ep) controlOpModify fd
    102      unless (res == 0) $ do
    103          err <- getErrno
    104          if err == eNOENT then
    105              with (Event ev fd) $ epollControl (epollFd ep) controlOpAdd fd
    106            else
    107              throwErrno "modifyFdOnce"
     104     if res == 0
     105       then return True
     106       else do err <- getErrno
     107               if err == eNOENT
     108                 then with (Event ev fd) $ \evptr -> do
     109                        epollControl (epollFd ep) controlOpAdd fd evptr
     110                        return True
     111                 else throwErrno "modifyFdOnce"
    108112
    109113-- | Select a set of file descriptors which are ready for I/O
    110114-- operations and call @f@ for all ready file descriptors, passing the
  • GHC/Event/Internal.hs

    diff --git a/GHC/Event/Internal.hs b/GHC/Event/Internal.hs
    index 7b25c86..a4c2e10 100644
    a b data Backend = forall a. Backend { 
    102102                  -> Fd       -- file descriptor
    103103                  -> Event    -- old events to watch for ('mempty' for new)
    104104                  -> Event    -- new events to watch for ('mempty' to delete)
    105                   -> IO ()
     105                  -> IO Bool
    106106
    107107    , _beModifyFdOnce :: a
    108108                         -> Fd    -- file descriptor
    109109                         -> Event -- new events to watch
    110                          -> IO ()
     110                         -> IO Bool
    111111
    112112    , _beDelete :: a -> IO ()
    113113    }
    114114
    115115backend :: (a -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int)
    116         -> (a -> Fd -> Event -> Event -> IO ())
    117         -> (a -> Fd -> Event -> IO ())
     116        -> (a -> Fd -> Event -> Event -> IO Bool)
     117        -> (a -> Fd -> Event -> IO Bool)
    118118        -> (a -> IO ())
    119119        -> a
    120120        -> Backend
    poll :: Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int 
    126126poll (Backend bState bPoll _ _ _) = bPoll bState
    127127{-# INLINE poll #-}
    128128
    129 modifyFd :: Backend -> Fd -> Event -> Event -> IO ()
     129-- | Returns 'True' if the modification succeeded.
     130-- Returns 'False' if this backend does not support
     131-- event notifications on this type of file.
     132modifyFd :: Backend -> Fd -> Event -> Event -> IO Bool
    130133modifyFd (Backend bState _ bModifyFd _ _) = bModifyFd bState
    131134{-# INLINE modifyFd #-}
    132135
    133 modifyFdOnce :: Backend -> Fd -> Event -> IO ()
     136-- | Returns 'True' if the modification succeeded.
     137-- Returns 'False' if this backend does not support
     138-- event notifications on this type of file.
     139modifyFdOnce :: Backend -> Fd -> Event -> IO Bool
    134140modifyFdOnce (Backend bState _ _ bModifyFdOnce _) = bModifyFdOnce bState
    135141{-# INLINE modifyFdOnce #-}
    136142
  • GHC/Event/KQueue.hsc

    diff --git a/GHC/Event/KQueue.hsc b/GHC/Event/KQueue.hsc
    index d157f64..683a5d9 100644
    a b import Data.Bits (Bits(..)) 
    3333import Data.Maybe (Maybe(..))
    3434import Data.Monoid (Monoid(..))
    3535import Data.Word (Word16, Word32)
    36 import Foreign.C.Error (throwErrnoIfMinus1)
     36import Foreign.C.Error (throwErrnoIfMinus1, eINTR, eINVAL, getErrno, throwErrno)
    3737import Foreign.C.Types
    3838import Foreign.Marshal.Alloc (alloca)
    3939import Foreign.Ptr (Ptr, nullPtr)
    delete kq = do 
    8888  _ <- c_close . fromKQueueFd . kqueueFd $ kq
    8989  return ()
    9090
    91 modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO ()
     91modifyFd :: KQueue -> Fd -> E.Event -> E.Event -> IO Bool
    9292modifyFd kq fd oevt nevt
    9393  | nevt == mempty = do
    9494      let !ev = event fd (toFilter oevt) flagDelete noteEOF
    toFilter evt 
    102102  | evt `E.eventIs` E.evtRead = filterRead
    103103  | otherwise                 = filterWrite
    104104
    105 modifyFdOnce :: KQueue -> Fd -> E.Event -> IO ()
     105modifyFdOnce :: KQueue -> Fd -> E.Event -> IO Bool
    106106modifyFdOnce kq fd evt = do
    107107    let !ev = event fd (toFilter evt) (flagAdd .|. flagOneshot) noteEOF
    108108    kqueueControl (kqueueFd kq) ev
    instance Storable TimeSpec where 
    224224kqueue :: IO KQueueFd
    225225kqueue = KQueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue
    226226
    227 kqueueControl :: KQueueFd -> Event -> IO ()
    228 kqueueControl kfd ev = void $
     227kqueueControl :: KQueueFd -> Event -> IO Bool
     228kqueueControl kfd ev =
    229229    withTimeSpec (TimeSpec 0 0) $ \tp ->
    230         withEvent ev $ \evp -> kevent False kfd evp 1 nullPtr 0 tp
    231 
     230        withEvent ev $ \evp -> do
     231            res <- kevent False kfd evp 1 nullPtr 0 tp
     232            if res == -1
     233              then do
     234               err <- getErrno
     235               case err of
     236                 _ | err == eINTR  -> return True
     237                 _ | err == eINVAL -> return False
     238                 _                 -> throwErrno "kevent"
     239              else return True
     240           
    232241kqueueWait :: KQueueFd -> Ptr Event -> Int -> TimeSpec -> IO Int
    233242kqueueWait fd es cap tm =
     243    fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
    234244    withTimeSpec tm $ kevent True fd nullPtr 0 es cap
    235245
    236246kqueueWaitNonBlock :: KQueueFd -> Ptr Event -> Int -> IO Int
    237247kqueueWaitNonBlock fd es cap =
     248    fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
    238249    withTimeSpec (TimeSpec 0 0) $ kevent False fd nullPtr 0 es cap
    239250
    240251-- TODO: We cannot retry on EINTR as the timeout would be wrong.
    241252-- Perhaps we should just return without calling any callbacks.
    242253kevent :: Bool -> KQueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec
    243        -> IO Int
     254       -> IO CInt
    244255kevent safe k chs chlen evs evlen ts
    245     = fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $
    246       if safe
    247       then c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
    248       else c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
     256  | safe      = c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
     257  | otherwise = c_kevent_unsafe k chs (fromIntegral chlen) evs (fromIntegral evlen) ts
    249258
    250259withEvent :: Event -> (Ptr Event -> IO a) -> IO a
    251260withEvent ev f = alloca $ \ptr -> poke ptr ev >> f ptr
  • GHC/Event/Manager.hs

    diff --git a/GHC/Event/Manager.hs b/GHC/Event/Manager.hs
    index 1dd9cc1..6021546 100644
    a b newWith oneShot be = do 
    193193  registerControlFd mgr (wakeupReadFd ctrl) evtRead
    194194  return mgr
    195195
     196failOnInvalidFile :: String -> Fd -> IO Bool -> IO ()
     197failOnInvalidFile loc fd m = do
     198  ok <- m
     199  when (not ok) $
     200    let msg = "Failed while attempting to modify registration of file " ++
     201              show fd ++ " at location " ++ loc
     202    in error msg
     203
    196204registerControlFd :: EventManager -> Fd -> Event -> IO ()
    197 registerControlFd mgr fd evs = I.modifyFd (emBackend mgr) fd mempty evs
     205registerControlFd mgr fd evs =
     206  failOnInvalidFile "registerControlFd" fd $
     207  I.modifyFd (emBackend mgr) fd mempty evs
    198208
    199209-- | Asynchronously shuts down the event manager, if running.
    200210shutdown :: EventManager -> IO ()
    registerFd_ mgr@(EventManager{..}) cb fd evs = do 
    284294  let fd'  = fromIntegral fd
    285295      reg  = FdKey fd u
    286296      !fdd = FdData reg evs cb
    287   modifyMVar (callbackTableVar mgr fd) $ \oldMap ->
     297  (modify,ok) <- modifyMVar (callbackTableVar mgr fd) $ \oldMap ->
    288298    if haveOneShot && emOneShot
    289     then case IM.insertWith (++) fd' [fdd] oldMap of
    290       (Nothing,   n) -> do I.modifyFdOnce emBackend fd evs
    291                            return (n, (reg, False))
    292       (Just prev, n) -> do I.modifyFdOnce emBackend fd (combineEvents evs prev)
    293                            return (n, (reg, False))
     299    then do let (n,evs') = case IM.insertWith (++) fd' [fdd] oldMap of
     300                  (Nothing,   n) -> (n, evs)
     301                  (Just prev, n) -> (n, combineEvents evs prev)
     302            ok <- I.modifyFdOnce emBackend fd evs'
     303            if ok
     304              then return (n, (False, True))
     305              else return (oldMap, (False, False))
    294306    else
    295307      let (!newMap, (oldEvs, newEvs)) =
    296308            case IM.insertWith (++) fd' [fdd] oldMap of
    297309              (Nothing,   n) -> (n, (mempty, evs))
    298310              (Just prev, n) -> (n, (eventsOf prev, combineEvents evs prev))
    299311          modify = oldEvs /= newEvs
    300       in do when modify $ I.modifyFd emBackend fd oldEvs newEvs
    301             return (newMap, (reg, modify))
     312      in do ok <- if modify
     313                  then I.modifyFd emBackend fd oldEvs newEvs
     314                  else return True
     315            return (newMap, (modify, ok))
     316  -- this simulates behavior of old IO manager:
     317  -- i.e. just call the callback if the registration fails.
     318  when (not ok) (cb reg evs)
     319  return (reg,modify)
    302320{-# INLINE registerFd_ #-}
    303321
    304322combineEvents :: Event -> [FdData] -> Event
    unregisterFd_ mgr@(EventManager{..}) (FdKey fd u) = 
    358376              (Nothing,   _)    -> (oldMap, (mempty, mempty))
    359377              (Just prev, newm) -> (newm, pairEvents prev newm fd')
    360378        modify = oldEvs /= newEvs
    361     when modify $
     379    when modify $ failOnInvalidFile "unregisterFd_" fd $
    362380      if haveOneShot && emOneShot && newEvs /= mempty
    363381      then I.modifyFdOnce emBackend fd newEvs
    364382      else I.modifyFd emBackend fd oldEvs newEvs
  • GHC/Event/Poll.hsc

    diff --git a/GHC/Event/Poll.hsc b/GHC/Event/Poll.hsc
    index 028a616..c5003ff 100644
    a b new :: IO E.Backend 
    5959new = E.backend poll modifyFd modifyFdOnce (\_ -> return ()) `liftM`
    6060      liftM2 Poll (newMVar =<< A.empty) A.empty
    6161
    62 modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO ()
     62modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO Bool
    6363modifyFd p fd oevt nevt =
    64   withMVar (pollChanges p) $ \ary ->
     64  withMVar (pollChanges p) $ \ary -> do
    6565    A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt)
     66    return True
    6667
    67 modifyFdOnce :: Poll -> Fd -> E.Event -> IO ()
     68modifyFdOnce :: Poll -> Fd -> E.Event -> IO Bool
    6869modifyFdOnce = error "modifyFdOnce not supported in Poll backend"
    6970
    7071reworkFd :: Poll -> PollFd -> IO ()