Ticket #7773: 7773.patch

File 7773.patch, 11.8 KB (added by AndreasVoellmy, 13 months 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 <andreas.voellmy@gmail.com>
    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 ()