From: Simon Marlow <simonmar@microsoft.com>
Date: Thu, 18 May 2006 11:33:03 +0000 (+0000)
Subject: Better error handling in the IO manager thread
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=77a47fd973802d084a2a0118e4906368196edc11;p=haskell-directory.git

Better error handling in the IO manager thread
In particular, handle EBADF just like rts/posix/Select.c, by waking up
all the waiting threads.  Other errors are thrown, instead of just
being ignored.
---

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index d36f95f..11d78b8 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -676,19 +676,26 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
 	  if (res == -1)
 	     then do
 		err <- getErrno
-		if err == eINTR
-			then do_select delays'
-			else return (res,delays')
+		case err of
+		  _ | err == eINTR ->  do_select delays'
+			-- EINTR: just redo the select()
+		  _ | err == eBADF ->  return (True, delays)
+			-- EBADF: one of the file descriptors is closed or bad,
+			-- we don't know which one, so wake everyone up.
+		  _ | otherwise    ->  throwErrno "select"
+			-- otherwise (ENOMEM or EINVAL) something has gone
+			-- wrong; report the error.
 	     else
-		return (res,delays')
+		return (False,delays')
 
-  (res,delays') <- do_select delays
-  -- ToDo: check result
+  (wakeup_all,delays') <- do_select delays
 
-  b <- fdIsSet wakeup readfds
-  if b == 0 
-    then return ()
-    else alloca $ \p -> do 
+  if wakeup_all then return ()
+    else do
+      b <- fdIsSet wakeup readfds
+      if b == 0 
+        then return ()
+        else alloca $ \p -> do 
 	    c_read (fromIntegral wakeup) p 1; return ()
 	    s <- peek p		
 	    if (s == 0xff) 
@@ -701,7 +708,9 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
   takeMVar prodding
   putMVar prodding False
 
-  reqs' <- completeRequests reqs readfds writefds []
+  reqs' <- if wakeup_all then do wakeupAll reqs; return []
+			 else completeRequests reqs readfds writefds []
+
   service_loop wakeup readfds writefds ptimeval reqs' delays'
 
 stick :: IORef Fd
@@ -753,6 +762,10 @@ completeRequests (Write fd m : reqs) readfds writefds reqs' = do
     then do putMVar m (); completeRequests reqs readfds writefds reqs'
     else completeRequests reqs readfds writefds (Write fd m : reqs')
 
+wakeupAll [] = return ()
+wakeupAll (Read  fd m : reqs) = do putMVar m (); wakeupAll reqs
+wakeupAll (Write fd m : reqs) = do putMVar m (); wakeupAll reqs
+
 waitForReadEvent :: Fd -> IO ()
 waitForReadEvent fd = do
   m <- newEmptyMVar