From: simonmar Date: Wed, 30 Nov 2005 16:56:24 +0000 (+0000) Subject: [project @ 2005-11-30 16:56:24 by simonmar] X-Git-Tag: Initial_conversion_from_CVS_complete~16 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b7564a80c1ce808319a396bafedd08fc97df05b3;p=haskell-directory.git [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 --- 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 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 --- 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); }