[project @ 2005-11-30 16:56:24 by simonmar]

- move forkIO into GHC.Conc, so that the I/O manager can use proper forkIO
  with an exception handler.  This required TopHandler.lhs-boot.  It's the
  right thing, though, since the forkIO implementation is GHC-specific.

- check for out-of-range file descriptors in the I/O manager, rather than
  just exploding.  The I/O manager will exit ungracefully, but at least
  there will be an error message.

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 233a686..f50da8a 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -24,6 +24,7 @@ module GHC.Conc
        ( ThreadId(..)
 
        -- Forking and suchlike
+       , forkIO        -- :: IO a -> IO ThreadId
        , myThreadId    -- :: IO ThreadId
        , killThread    -- :: ThreadId -> IO ()
        , throwTo       -- :: ThreadId -> Exception -> IO ()
@@ -80,6 +81,8 @@ import System.Posix.Internals
 import Foreign
 import Foreign.C
 
+import {-# SOURCE #-} GHC.TopHandler ( reportError, reportStackOverflow )
+
 import Data.Maybe
 
 import GHC.Base
@@ -87,7 +90,7 @@ import GHC.IOBase
 import GHC.Num         ( Num(..) )
 import GHC.Real                ( fromIntegral, quot )
 import GHC.Base                ( Int(..) )
-import GHC.Exception    ( Exception(..), AsyncException(..) )
+import GHC.Exception    ( catchException, Exception(..), AsyncException(..) )
 import GHC.Pack                ( packCString# )
 import GHC.Ptr          ( Ptr(..), plusPtr, FunPtr(..) )
 import GHC.STRef
@@ -125,7 +128,34 @@ This misfeature will hopefully be corrected at a later date.
 it defines 'ThreadId' as a synonym for ().
 -}
 
---forkIO has now been hoisted out into the Concurrent library.
+{- |
+This sparks off a new thread to run the 'IO' computation passed as the
+first argument, and returns the 'ThreadId' of the newly created
+thread.
+
+The new thread will be a lightweight thread; if you want to use a foreign
+library that uses thread-local storage, use 'forkOS' instead.
+-}
+forkIO :: IO () -> IO ThreadId
+forkIO action = IO $ \ s -> 
+   case (fork# 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
+
+real_handler :: Exception -> IO ()
+real_handler ex =
+  case ex of
+       -- ignore thread GC and killThread exceptions:
+       BlockedOnDeadMVar            -> return ()
+       BlockedIndefinitely          -> return ()
+       AsyncException ThreadKilled  -> return ()
+
+       -- report all others:
+       AsyncException StackOverflow -> reportStackOverflow
+       other       -> reportError other
 
 {- | 'killThread' terminates the given thread (GHC only).
 Any work already done by the thread isn\'t
@@ -564,17 +594,13 @@ startIOManagerThread = do
        wr_end <- peekElemOff fds 1
        writeIORef stick (fromIntegral wr_end)
        c_setIOManagerPipe wr_end
-       quickForkIO $ do
+       forkIO $ do
            allocaBytes sizeofFdSet   $ \readfds -> do
            allocaBytes sizeofFdSet   $ \writefds -> do 
            allocaBytes sizeofTimeVal $ \timeval -> do
            service_loop (fromIntegral rd_end) readfds writefds timeval [] []
        return ()
 
--- XXX: move real forkIO here from Control.Concurrent?
-quickForkIO action = IO $ \s ->
-   case (fork# action s) of (# s1, id #) -> (# s1, ThreadId id #)
-
 service_loop
    :: Fd               -- listen to this for wakeup calls
    -> Ptr CFdSet
@@ -631,7 +657,7 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
              then return ()
              else do handler_tbl <- peek handlers
                      sp <- peekElemOff handler_tbl (fromIntegral s)
-                     quickForkIO (do io <- deRefStablePtr sp; io)
+                     forkIO (do io <- deRefStablePtr sp; io)
                      return ()
 
   takeMVar prodding
@@ -666,12 +692,16 @@ foreign import ccall "setIOManagerPipe"
 -- IO requests
 
 buildFdSets maxfd readfds writefds [] = return maxfd
-buildFdSets maxfd readfds writefds (Read fd m : reqs) = do
-  fdSet fd readfds
-  buildFdSets (max maxfd fd) readfds writefds reqs
-buildFdSets maxfd readfds writefds (Write fd m : reqs) = do
-  fdSet fd writefds
-  buildFdSets (max maxfd fd) readfds writefds reqs
+buildFdSets maxfd readfds writefds (Read fd m : reqs)
+  | fd >= fD_SETSIZE =  error "buildFdSets: file descriptor out of range"
+  | otherwise        =  do
+       fdSet fd readfds
+        buildFdSets (max maxfd fd) readfds writefds reqs
+buildFdSets maxfd readfds writefds (Write fd m : reqs)
+  | fd >= fD_SETSIZE =  error "buildFdSets: file descriptor out of range"
+  | otherwise        =  do
+       fdSet fd writefds
+       buildFdSets (max maxfd fd) readfds writefds reqs
 
 completeRequests [] _ _ reqs' = return reqs'
 completeRequests (Read fd m : reqs) readfds writefds reqs' = do
@@ -777,6 +807,9 @@ foreign import ccall safe "select"
   c_select :: Fd -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
            -> IO CInt
 
+foreign import ccall unsafe "hsFD_SETSIZE"
+  fD_SETSIZE :: Fd
+
 foreign import ccall unsafe "hsFD_CLR"
   fdClr :: Fd -> Ptr CFdSet -> IO ()
 

diff --git a/GHC/TopHandler.lhs-boot b/GHC/TopHandler.lhs-boot
new file mode 100644 (file)
index 0000000..af6170a
--- /dev/null
+++ b/GHC/TopHandler.lhs-boot
@@ -0,0 +1,10 @@
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+module GHC.TopHandler ( reportError, reportStackOverflow ) where
+
+import GHC.Exception ( Exception )
+import GHC.IOBase    ( IO )
+
+reportError :: Exception -> IO a
+reportStackOverflow :: IO a
+\end{code}

diff --git a/include/HsBase.h b/include/HsBase.h
index 935da37..57873e0 100644 (file)
--- a/include/HsBase.h
+++ b/include/HsBase.h
@@ -700,6 +700,7 @@ INLINE int __hscore_fstat(int fd, struct stat *buf) {
 // select-related stuff
 
 #if !defined(mingw32_HOST_OS)
+INLINE int  hsFD_SETSIZE(void) { return FD_SETSIZE; }
 INLINE void hsFD_CLR(int fd, fd_set *fds) { FD_CLR(fd, fds); }
 INLINE int  hsFD_ISSET(int fd, fd_set *fds) { return FD_ISSET(fd, fds); }
 INLINE void hsFD_SET(int fd, fd_set *fds) { FD_SET(fd, fds); }