Better error handling in the IO manager thread

[haskell-directory.git] / GHC / Conc.lhs

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 6c21cf4..11d78b8 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -25,6 +25,7 @@ module GHC.Conc
 
        -- Forking and suchlike
        , forkIO        -- :: IO a -> IO ThreadId
+       , forkOnIO      -- :: Int -> IO a -> IO ThreadId
        , childHandler  -- :: Exception -> IO ()
        , myThreadId    -- :: IO ThreadId
        , killThread    -- :: ThreadId -> IO ()
@@ -59,6 +60,7 @@ module GHC.Conc
         , catchSTM      -- :: STM a -> (Exception -> STM a) -> STM a
        , TVar          -- abstract
        , newTVar       -- :: a -> STM (TVar a)
+       , newTVarIO     -- :: a -> STM (TVar a)
        , readTVar      -- :: TVar a -> STM a
        , writeTVar     -- :: a -> TVar a -> STM ()
        , unsafeIOToSTM -- :: IO a -> STM a
@@ -145,6 +147,12 @@ forkIO action = IO $ \ s ->
  where
   action_plus = catchException action childHandler
 
+forkOnIO :: Int -> IO () -> IO ThreadId
+forkOnIO (I# cpu) action = IO $ \ s -> 
+   case (forkOn# cpu action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
+ where
+  action_plus = catchException action childHandler
+
 childHandler :: Exception -> IO ()
 childHandler err = catchException (real_handler err) childHandler
 
@@ -321,6 +329,15 @@ newTVar val = STM $ \s1# ->
     case newTVar# val s1# of
         (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
 
+-- |@IO@ version of 'newTVar'.  This is useful for creating top-level
+-- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
+-- possible.
+newTVarIO :: a -> IO (TVar a)
+newTVarIO val = IO $ \s1# ->
+    case newTVar# val s1# of
+        (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
+
 -- |Return the current value stored in a TVar
 readTVar :: TVar a -> STM a
 readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s#
@@ -367,16 +384,34 @@ newMVar value =
 -- empty, 'takeMVar' will wait until it is full.  After a 'takeMVar', 
 -- the 'MVar' is left empty.
 -- 
--- If several threads are competing to take the same 'MVar', one is chosen
--- to continue at random when the 'MVar' becomes full.
+-- There are two further important properties of 'takeMVar':
+--
+--   * 'takeMVar' is single-wakeup.  That is, if there are multiple
+--     threads blocked in 'takeMVar', and the 'MVar' becomes full,
+--     only one thread will be woken up.  The runtime guarantees that
+--     the woken thread completes its 'takeMVar' operation.
+--
+--   * When multiple threads are blocked on an 'MVar', they are
+--     woken up in FIFO order.  This is useful for providing
+--     fairness properties of abstractions built using 'MVar's.
+--
 takeMVar :: MVar a -> IO a
 takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
 
 -- |Put a value into an 'MVar'.  If the 'MVar' is currently full,
 -- 'putMVar' will wait until it becomes empty.
 --
--- If several threads are competing to fill the same 'MVar', one is
--- chosen to continue at random when the 'MVar' becomes empty.
+-- There are two further important properties of 'putMVar':
+--
+--   * 'putMVar' is single-wakeup.  That is, if there are multiple
+--     threads blocked in 'putMVar', and the 'MVar' becomes empty,
+--     only one thread will be woken up.  The runtime guarantees that
+--     the woken thread completes its 'putMVar' operation.
+--
+--   * When multiple threads are blocked on an 'MVar', they are
+--     woken up in FIFO order.  This is useful for providing
+--     fairness properties of abstractions built using 'MVar's.
+--
 putMVar  :: MVar a -> a -> IO ()
 putMVar (MVar mvar#) x = IO $ \ s# ->
     case putMVar# mvar# x s# of
@@ -641,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) 
@@ -666,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
@@ -718,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