[GHC] #7653: incorrect handling of StackOverflow exception in the event manager

[GHC]

#7653: incorrect handling of StackOverflow exception in the event manager
--------------------------+-------------------------------------------------
Reporter:  nus            |          Owner:                  
    Type:  bug            |         Status:  new             
Priority:  normal         |      Component:  libraries/base  
 Version:  7.7            |       Keywords:                  
      Os:  Linux          |   Architecture:  Unknown/Multiple
 Failure:  Runtime crash  |      Blockedby:                  
Blocking:                 |        Related:                  
--------------------------+-------------------------------------------------

Comment(by nus):

 `libraries\base\GHC\Event\Manager.hs`, the thunk accummulated in `f'`:
 {{{
 registerTimeout :: EventManager -> Int -> TimeoutCallback -> IO TimeoutKey
 registerTimeout mgr us cb = do
   !key <- newUnique (emUniqueSource mgr)
   if us <= 0 then cb
     else do
       now <- getMonotonicTime
       let expTime = fromIntegral us / 1000000.0 + now

       -- We intentionally do not evaluate the modified map to WHNF here.
       -- Instead, we leave a thunk inside the IORef and defer its
       -- evaluation until mkTimeout in the event loop.  This is a
       -- workaround for a nasty IORef contention problem that causes the
       -- thread-delay benchmark to take 20 seconds instead of 0.2.
       atomicModifyIORef (emTimeouts mgr) $ \f ->
           let f' = (Q.insert key expTime cb) . f in (f', ())
       wakeManager mgr
   return $ TK key
 }}}
 is evaluated in `applyEdits`:
 {{{
 step :: EventManager -> TimeoutQueue -> IO (Bool, TimeoutQueue)
 step mgr at EventManager{..} tq = do
   (timeout, q') <- mkTimeout tq
   I.poll emBackend timeout (onFdEvent mgr)
   state <- readIORef emState
   state `seq` return (state == Running, q')
  where

   -- | Call all expired timer callbacks and return the time to the
   -- next timeout.
   mkTimeout :: TimeoutQueue -> IO (Timeout, TimeoutQueue)
   mkTimeout q = do
       now <- getMonotonicTime
       applyEdits <- atomicModifyIORef emTimeouts $ \f -> (id, f)
       let (expired, q'') = let q' = applyEdits q in q' `seq` Q.atMost now
 q'
       sequence_ $ map Q.value expired
       let timeout = case Q.minView q'' of
             Nothing             -> Forever
             Just (Q.E _ t _, _) ->
                 -- This value will always be positive since the call
                 -- to 'atMost' above removed any timeouts <= 'now'
                 let t' = t - now in t' `seq` Timeout t'
       return (timeout, q'')
 }}}
 The main `loop :: EventManager -> IO ()` in `cleanup :: EventManager -> IO
 ()` uses:
 {{{
 closeControl :: Control -> IO ()
 closeControl w = do
   _ <- c_close . fromIntegral . controlReadFd $ w
   _ <- c_close . fromIntegral . controlWriteFd $ w
 #if defined(HAVE_EVENTFD)
   _ <- c_close . fromIntegral . controlEventFd $ w
 #else
   _ <- c_close . fromIntegral . wakeupReadFd $ w
   _ <- c_close . fromIntegral . wakeupWriteFd $ w
 #endif
   return ()
 }}}
 which doesn't clean up the C side of `newControl :: IO Control`.

-- 
Ticket URL: <http://hackage.haskell.org/trac/ghc/ticket/7653#comment:1>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler