X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=d47ba0b5fc59e6f6886350755237370a7c825cc8;hb=fb80d56c0b7617261c93a808e9001bbb25a7562e;hp=6ec6c760a9372cdc0866d4722465752f1286d8a3;hpb=83959f85423c73a5f0be806978791edff265c2e5;p=ghc-base.git diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index 6ec6c76..d47ba0b 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -1,5 +1,5 @@ \begin{code} -{-# OPTIONS_GHC -fno-implicit-prelude #-} +{-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- | @@ -24,74 +24,81 @@ -- #not-home module GHC.Conc - ( ThreadId(..) + ( ThreadId(..) - -- * Forking and suchlike - , forkIO -- :: IO a -> IO ThreadId - , forkOnIO -- :: Int -> IO a -> IO ThreadId + -- * Forking and suchlike + , forkIO -- :: IO a -> IO ThreadId + , forkOnIO -- :: Int -> IO a -> IO ThreadId , numCapabilities -- :: Int - , childHandler -- :: Exception -> IO () - , myThreadId -- :: IO ThreadId - , killThread -- :: ThreadId -> IO () - , throwTo -- :: ThreadId -> Exception -> IO () - , par -- :: a -> b -> b - , pseq -- :: a -> b -> b - , yield -- :: IO () - , labelThread -- :: ThreadId -> String -> IO () - - -- * Waiting - , threadDelay -- :: Int -> IO () - , registerDelay -- :: Int -> IO (TVar Bool) - , threadWaitRead -- :: Int -> IO () - , threadWaitWrite -- :: Int -> IO () - - -- * MVars - , MVar(..) - , newMVar -- :: a -> IO (MVar a) - , newEmptyMVar -- :: IO (MVar a) - , takeMVar -- :: MVar a -> IO a - , putMVar -- :: MVar a -> a -> IO () - , tryTakeMVar -- :: MVar a -> IO (Maybe a) - , tryPutMVar -- :: MVar a -> a -> IO Bool - , isEmptyMVar -- :: MVar a -> IO Bool - , addMVarFinalizer -- :: MVar a -> IO () -> IO () - - -- * TVars - , STM(..) - , atomically -- :: STM a -> IO a - , retry -- :: STM a - , orElse -- :: STM a -> STM a -> STM a + , childHandler -- :: Exception -> IO () + , myThreadId -- :: IO ThreadId + , killThread -- :: ThreadId -> IO () + , throwTo -- :: ThreadId -> Exception -> IO () + , par -- :: a -> b -> b + , pseq -- :: a -> b -> b + , yield -- :: IO () + , labelThread -- :: ThreadId -> String -> IO () + + , ThreadStatus(..), BlockReason(..) + , threadStatus -- :: ThreadId -> IO ThreadStatus + + -- * Waiting + , threadDelay -- :: Int -> IO () + , registerDelay -- :: Int -> IO (TVar Bool) + , threadWaitRead -- :: Int -> IO () + , threadWaitWrite -- :: Int -> IO () + + -- * MVars + , MVar(..) + , newMVar -- :: a -> IO (MVar a) + , newEmptyMVar -- :: IO (MVar a) + , takeMVar -- :: MVar a -> IO a + , putMVar -- :: MVar a -> a -> IO () + , tryTakeMVar -- :: MVar a -> IO (Maybe a) + , tryPutMVar -- :: MVar a -> a -> IO Bool + , isEmptyMVar -- :: MVar a -> IO Bool + , addMVarFinalizer -- :: MVar a -> IO () -> IO () + + -- * TVars + , STM(..) + , atomically -- :: STM a -> IO a + , retry -- :: STM a + , orElse -- :: STM a -> STM a -> STM a , catchSTM -- :: STM a -> (Exception -> STM a) -> STM a - , alwaysSucceeds -- :: STM a -> STM () - , always -- :: STM Bool -> STM () - , TVar(..) - , 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 - - -- * Miscellaneous + , alwaysSucceeds -- :: STM a -> STM () + , always -- :: STM Bool -> STM () + , TVar(..) + , 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 + + -- * Miscellaneous #ifdef mingw32_HOST_OS - , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) - , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) - , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int + , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) + , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) + , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int - , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) - , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) + , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) + , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) #endif #ifndef mingw32_HOST_OS , signalHandlerLock #endif - , ensureIOManagerIsRunning + , ensureIOManagerIsRunning #ifdef mingw32_HOST_OS , ConsoleEvent(..) , win32ConsoleHandler , toWin32ConsoleEvent #endif + , setUncaughtExceptionHandler -- :: (Exception -> IO ()) -> IO () + , getUncaughtExceptionHandler -- :: IO (Exception -> IO ()) + + , reportError, reportStackOverflow ) where import System.Posix.Types @@ -101,37 +108,36 @@ import System.Posix.Internals import Foreign import Foreign.C -#ifndef __HADDOCK__ -import {-# SOURCE #-} GHC.TopHandler ( reportError, reportStackOverflow ) -#endif - import Data.Maybe import GHC.Base +import {-# SOURCE #-} GHC.Handle import GHC.IOBase -import GHC.Num ( Num(..) ) -import GHC.Real ( fromIntegral, div ) -#ifndef mingw32_HOST_OS -import GHC.Base ( Int(..) ) +import GHC.Num ( Num(..) ) +import GHC.Real ( fromIntegral ) +#ifdef mingw32_HOST_OS +import GHC.Real ( div ) +import GHC.Ptr ( plusPtr, FunPtr(..) ) #endif #ifdef mingw32_HOST_OS import GHC.Read ( Read ) import GHC.Enum ( Enum ) #endif -import GHC.Exception -import GHC.Pack ( packCString# ) -import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) ) +import GHC.Exception ( SomeException(..), throw ) +import GHC.Pack ( packCString# ) +import GHC.Ptr ( Ptr(..) ) import GHC.STRef -import GHC.Show ( Show(..), showString ) +import GHC.Show ( Show(..), showString ) import Data.Typeable +import GHC.Err infixr 0 `par`, `pseq` \end{code} %************************************************************************ -%* * +%* * \subsection{@ThreadId@, @par@, and @fork@} -%* * +%* * %************************************************************************ \begin{code} @@ -159,7 +165,7 @@ it defines 'ThreadId' as a synonym for (). instance Show ThreadId where showsPrec d t = - showString "ThreadId " . + showString "ThreadId " . showsPrec d (getThreadId (id2TSO t)) foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt @@ -233,20 +239,22 @@ numCapabilities = unsafePerformIO $ do foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt -childHandler :: Exception -> IO () +childHandler :: SomeException -> 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 +real_handler :: SomeException -> IO () +real_handler se@(SomeException ex) = + -- ignore thread GC and killThread exceptions: + case cast ex of + Just BlockedOnDeadMVar -> return () + _ -> case cast ex of + Just BlockedIndefinitely -> return () + _ -> case cast ex of + Just ThreadKilled -> return () + _ -> case cast ex of + -- report all others: + Just StackOverflow -> reportStackOverflow + _ -> reportError se {- | 'killThread' terminates the given thread (GHC only). Any work already done by the thread isn\'t @@ -259,7 +267,7 @@ terms of 'throwTo': -} killThread :: ThreadId -> IO () -killThread tid = throwTo tid (AsyncException ThreadKilled) +killThread tid = throwTo tid (toException ThreadKilled) {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only). @@ -291,7 +299,8 @@ unblock and then re-block exceptions (using 'unblock' and 'block') without recei a pending 'throwTo'. This is arguably undesirable behaviour. -} -throwTo :: ThreadId -> Exception -> IO () +-- XXX This is duplicated in Control.{Old,}Exception +throwTo :: ThreadId -> SomeException -> IO () throwTo (ThreadId id) ex = IO $ \ s -> case (killThread# id ex s) of s1 -> (# s1, () #) @@ -325,8 +334,8 @@ labelThread (ThreadId t) str = IO $ \ s -> adr = byteArrayContents# ps in case (labelThread# t adr s) of s1 -> (# s1, () #) --- Nota Bene: 'pseq' used to be 'seq' --- but 'seq' is now defined in PrelGHC +-- Nota Bene: 'pseq' used to be 'seq' +-- but 'seq' is now defined in PrelGHC -- -- "pseq" is defined a bit weirdly (see below) -- @@ -343,13 +352,60 @@ pseq x y = x `seq` lazy y {-# INLINE par #-} par :: a -> b -> b par x y = case (par# x) of { _ -> lazy y } + + +data BlockReason + = BlockedOnMVar + -- ^blocked on on 'MVar' + | BlockedOnBlackHole + -- ^blocked on a computation in progress by another thread + | BlockedOnException + -- ^blocked in 'throwTo' + | BlockedOnSTM + -- ^blocked in 'retry' in an STM transaction + | BlockedOnForeignCall + -- ^currently in a foreign call + | BlockedOnOther + -- ^blocked on some other resource. Without @-threaded@, + -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@ + -- they show up as 'BlockedOnMVar'. + deriving (Eq,Ord,Show) + +-- | The current status of a thread +data ThreadStatus + = ThreadRunning + -- ^the thread is currently runnable or running + | ThreadFinished + -- ^the thread has finished + | ThreadBlocked BlockReason + -- ^the thread is blocked on some resource + | ThreadDied + -- ^the thread received an uncaught exception + deriving (Eq,Ord,Show) + +threadStatus :: ThreadId -> IO ThreadStatus +threadStatus (ThreadId t) = IO $ \s -> + case threadStatus# t s of + (# s', stat #) -> (# s', mk_stat (I# stat) #) + where + -- NB. keep these in sync with includes/Constants.h + mk_stat 0 = ThreadRunning + mk_stat 1 = ThreadBlocked BlockedOnMVar + mk_stat 2 = ThreadBlocked BlockedOnBlackHole + mk_stat 3 = ThreadBlocked BlockedOnException + mk_stat 7 = ThreadBlocked BlockedOnSTM + mk_stat 11 = ThreadBlocked BlockedOnForeignCall + mk_stat 12 = ThreadBlocked BlockedOnForeignCall + mk_stat 16 = ThreadFinished + mk_stat 17 = ThreadDied + mk_stat _ = ThreadBlocked BlockedOnOther \end{code} %************************************************************************ -%* * +%* * \subsection[stm]{Transactional heap operations} -%* * +%* * %************************************************************************ TVars are shared memory locations which support atomic memory @@ -372,7 +428,7 @@ instance Monad STM where {-# INLINE (>>) #-} {-# INLINE (>>=) #-} m >> k = thenSTM m k - return x = returnSTM x + return x = returnSTM x m >>= k = bindSTM m k bindSTM :: STM a -> (a -> STM b) -> STM b @@ -390,7 +446,26 @@ thenSTM (STM m) k = STM ( \s -> returnSTM :: a -> STM a returnSTM x = STM (\s -> (# s, x #)) --- | Unsafely performs IO in the STM monad. +-- | Unsafely performs IO in the STM monad. Beware: this is a highly +-- dangerous thing to do. +-- +-- * The STM implementation will often run transactions multiple +-- times, so you need to be prepared for this if your IO has any +-- side effects. +-- +-- * The STM implementation will abort transactions that are known to +-- be invalid and need to be restarted. This may happen in the middle +-- of `unsafeIOToSTM`, so make sure you don't acquire any resources +-- that need releasing (exception handlers are ignored when aborting +-- the transaction). That includes doing any IO using Handles, for +-- example. Getting this wrong will probably lead to random deadlocks. +-- +-- * The transaction may have seen an inconsistent view of memory when +-- the IO runs. Invariants that you expect to be true throughout +-- your program may not be true inside a transaction, due to the +-- way transactions are implemented. Normally this wouldn't be visible +-- to the programmer, but using `unsafeIOToSTM` can expose it. +-- unsafeIOToSTM :: IO a -> STM a unsafeIOToSTM (IO m) = STM m @@ -424,7 +499,7 @@ orElse :: STM a -> STM a -> STM a orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s -- |Exception handling within STM actions. -catchSTM :: STM a -> (Exception -> STM a) -> STM a +catchSTM :: STM a -> (SomeException -> STM a) -> STM a catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s -- | Low-level primitive on which always and alwaysSucceeds are built. @@ -457,13 +532,13 @@ data TVar a = TVar (TVar# RealWorld a) INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar") instance Eq (TVar a) where - (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2# + (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2# -- |Create a new TVar holding a value supplied newTVar :: a -> STM (TVar a) newTVar val = STM $ \s1# -> case newTVar# val s1# of - (# s2#, tvar# #) -> (# s2#, TVar tvar# #) + (# 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 @@ -472,7 +547,7 @@ newTVar val = STM $ \s1# -> newTVarIO :: a -> IO (TVar a) newTVarIO val = IO $ \s1# -> case newTVar# val s1# of - (# s2#, tvar# #) -> (# s2#, TVar tvar# #) + (# s2#, tvar# #) -> (# s2#, TVar tvar# #) -- |Return the current value stored in a TVar readTVar :: TVar a -> STM a @@ -482,14 +557,14 @@ readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s# writeTVar :: TVar a -> a -> STM () writeTVar (TVar tvar#) val = STM $ \s1# -> case writeTVar# tvar# val s1# of - s2# -> (# s2#, () #) + s2# -> (# s2#, () #) \end{code} %************************************************************************ -%* * +%* * \subsection[mvars]{M-Structures} -%* * +%* * %************************************************************************ M-Vars are rendezvous points for concurrent threads. They begin @@ -512,8 +587,8 @@ newEmptyMVar = IO $ \ s# -> -- |Create an 'MVar' which contains the supplied value. newMVar :: a -> IO (MVar a) newMVar value = - newEmptyMVar >>= \ mvar -> - putMVar mvar value >> + newEmptyMVar >>= \ mvar -> + putMVar mvar value >> return mvar -- |Return the contents of the 'MVar'. If the 'MVar' is currently @@ -560,8 +635,8 @@ putMVar (MVar mvar#) x = IO $ \ s# -> tryTakeMVar :: MVar a -> IO (Maybe a) tryTakeMVar (MVar m) = IO $ \ s -> case tryTakeMVar# m s of - (# s, 0#, _ #) -> (# s, Nothing #) -- MVar is empty - (# s, _, a #) -> (# s, Just a #) -- MVar is full + (# s, 0#, _ #) -> (# s, Nothing #) -- MVar is empty + (# s, _, a #) -> (# s, Just a #) -- MVar is full -- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function -- attempts to put the value @a@ into the 'MVar', returning 'True' if @@ -593,17 +668,17 @@ withMVar :: MVar a -> (a -> IO b) -> IO b withMVar m io = block $ do a <- takeMVar m - b <- catchException (unblock (io a)) - (\e -> do putMVar m a; throw e) + b <- catchAny (unblock (io a)) + (\e -> do putMVar m a; throw e) putMVar m a return b \end{code} %************************************************************************ -%* * +%* * \subsection{Thread waiting} -%* * +%* * %************************************************************************ \begin{code} @@ -616,19 +691,19 @@ withMVar m io = asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) = IO $ \s -> case asyncRead# fd isSock len buf s of - (# s, len#, err# #) -> (# s, (I# len#, I# err#) #) + (# s, len#, err# #) -> (# s, (I# len#, I# err#) #) asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) = IO $ \s -> case asyncWrite# fd isSock len buf s of - (# s, len#, err# #) -> (# s, (I# len#, I# err#) #) + (# s, len#, err# #) -> (# s, (I# len#, I# err#) #) asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int asyncDoProc (FunPtr proc) (Ptr param) = -- the 'length' value is ignored; simplifies implementation of -- the async*# primops to have them all return the same result. IO $ \s -> case asyncDoProc# proc param s of - (# s, len#, err# #) -> (# s, I# err# #) + (# s, len#, err# #) -> (# s, I# err# #) -- to aid the use of these primops by the IO Handle implementation, -- provide the following convenience funs: @@ -655,9 +730,9 @@ threadWaitRead fd | threaded = waitForReadEvent fd #endif | otherwise = IO $ \s -> - case fromIntegral fd of { I# fd# -> - case waitRead# fd# s of { s -> (# s, () #) - }} + case fromIntegral fd of { I# fd# -> + case waitRead# fd# s of { s -> (# s, () #) + }} -- | Block the current thread until data can be written to the -- given file descriptor (GHC only). @@ -667,9 +742,9 @@ threadWaitWrite fd | threaded = waitForWriteEvent fd #endif | otherwise = IO $ \s -> - case fromIntegral fd of { I# fd# -> - case waitWrite# fd# s of { s -> (# s, () #) - }} + case fromIntegral fd of { I# fd# -> + case waitWrite# fd# s of { s -> (# s, () #) + }} -- | Suspends the current thread for a given number of microseconds -- (GHC only). @@ -682,9 +757,9 @@ threadDelay :: Int -> IO () threadDelay time | threaded = waitForDelayEvent time | otherwise = IO $ \s -> - case fromIntegral time of { I# time# -> - case delay# time# s of { s -> (# s, () #) - }} + case fromIntegral time of { I# time# -> + case delay# time# s of { s -> (# s, () #) + }} -- | Set the value of returned TVar to True after a given number of @@ -737,20 +812,20 @@ calculateTarget usecs = do -- Issues, possible problems: -- --- - we might want bound threads to just do the blocking --- operation rather than communicating with the IO manager --- thread. This would prevent simgle-threaded programs which do --- IO from requiring multiple OS threads. However, it would also --- prevent bound threads waiting on IO from being killed or sent --- exceptions. +-- - we might want bound threads to just do the blocking +-- operation rather than communicating with the IO manager +-- thread. This would prevent simgle-threaded programs which do +-- IO from requiring multiple OS threads. However, it would also +-- prevent bound threads waiting on IO from being killed or sent +-- exceptions. -- --- - Apprently exec() doesn't work on Linux in a multithreaded program. --- I couldn't repeat this. +-- - Apprently exec() doesn't work on Linux in a multithreaded program. +-- I couldn't repeat this. -- --- - How do we handle signal delivery in the multithreaded RTS? +-- - How do we handle signal delivery in the multithreaded RTS? -- --- - forkProcess will kill the IO manager thread. Let's just --- hope we don't need to do any blocking IO between fork & exec. +-- - forkProcess will kill the IO manager thread. Let's just +-- hope we don't need to do any blocking IO between fork & exec. #ifndef mingw32_HOST_OS data IOReq @@ -766,7 +841,7 @@ data DelayReq pendingEvents :: IORef [IOReq] #endif pendingDelays :: IORef [DelayReq] - -- could use a strict list or array here + -- could use a strict list or array here {-# NOINLINE pendingEvents #-} {-# NOINLINE pendingDelays #-} (pendingEvents,pendingDelays) = unsafePerformIO $ do @@ -774,8 +849,8 @@ pendingDelays :: IORef [DelayReq] reqs <- newIORef [] dels <- newIORef [] return (reqs, dels) - -- the first time we schedule an IO request, the service thread - -- will be created (cool, huh?) + -- the first time we schedule an IO request, the service thread + -- will be created (cool, huh?) ensureIOManagerIsRunning :: IO () ensureIOManagerIsRunning @@ -838,11 +913,11 @@ service_loop wakeup old_delays = do 0 -> do r <- c_readIOManagerEvent exit <- - case r of - _ | r == io_MANAGER_WAKEUP -> return False - _ | r == io_MANAGER_DIE -> return True + case r of + _ | r == io_MANAGER_WAKEUP -> return False + _ | r == io_MANAGER_DIE -> return True 0 -> return False -- spurious wakeup - r -> do start_console_handler (r `shiftR` 1); return False + r -> do start_console_handler (r `shiftR` 1); return False if exit then return () else service_cont wakeup delays' @@ -902,11 +977,11 @@ getDelay now [] = return ([], iNFINITE) getDelay now all@(d : rest) = case d of Delay time m | now >= time -> do - putMVar m () - getDelay now rest + putMVar m () + getDelay now rest DelaySTM time t | now >= time -> do - atomically $ writeTVar t True - getDelay now rest + atomically $ writeTVar t True + getDelay now rest _otherwise -> -- delay is in millisecs for WaitForSingleObject let micro_seconds = delayTime d - now @@ -943,20 +1018,20 @@ foreign import stdcall "WaitForSingleObject" startIOManagerThread :: IO () startIOManagerThread = do allocaArray 2 $ \fds -> do - throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds) - rd_end <- peekElemOff fds 0 - wr_end <- peekElemOff fds 1 - writeIORef stick (fromIntegral wr_end) - c_setIOManagerPipe wr_end - forkIO $ do - allocaBytes sizeofFdSet $ \readfds -> do - allocaBytes sizeofFdSet $ \writefds -> do - allocaBytes sizeofTimeVal $ \timeval -> do - service_loop (fromIntegral rd_end) readfds writefds timeval [] [] - return () + throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds) + rd_end <- peekElemOff fds 0 + wr_end <- peekElemOff fds 1 + writeIORef stick (fromIntegral wr_end) + c_setIOManagerPipe wr_end + forkIO $ do + allocaBytes sizeofFdSet $ \readfds -> do + allocaBytes sizeofFdSet $ \writefds -> do + allocaBytes sizeofTimeVal $ \timeval -> do + service_loop (fromIntegral rd_end) readfds writefds timeval [] [] + return () service_loop - :: Fd -- listen to this for wakeup calls + :: Fd -- listen to this for wakeup calls -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal @@ -981,28 +1056,28 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do -- perform the select() let do_select delays = do - -- check the current time and wake up any thread in - -- threadDelay whose timeout has expired. Also find the - -- timeout value for the select() call. - now <- getUSecOfDay - (delays', timeout) <- getDelay now ptimeval delays - - res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds - nullPtr timeout - if (res == -1) - then do - err <- getErrno - 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 (False,delays') + -- check the current time and wake up any thread in + -- threadDelay whose timeout has expired. Also find the + -- timeout value for the select() call. + now <- getUSecOfDay + (delays', timeout) <- getDelay now ptimeval delays + + res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds + nullPtr timeout + if (res == -1) + then do + err <- getErrno + 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 (False,delays') (wakeup_all,delays') <- do_select delays @@ -1013,24 +1088,24 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do if b == 0 then return False else alloca $ \p -> do - c_read (fromIntegral wakeup) p 1; return () - s <- peek p - case s of - _ | s == io_MANAGER_WAKEUP -> return False - _ | s == io_MANAGER_DIE -> return True - _ -> withMVar signalHandlerLock $ \_ -> do + c_read (fromIntegral wakeup) p 1; return () + s <- peek p + case s of + _ | s == io_MANAGER_WAKEUP -> return False + _ | s == io_MANAGER_DIE -> return True + _ -> withMVar signalHandlerLock $ \_ -> do handler_tbl <- peek handlers - sp <- peekElemOff handler_tbl (fromIntegral s) + sp <- peekElemOff handler_tbl (fromIntegral s) io <- deRefStablePtr sp - forkIO io - return False + forkIO io + return False if exit then return () else do atomicModifyIORef prodding (\_ -> (False,False)) reqs' <- if wakeup_all then do wakeupAll reqs; return [] - else completeRequests reqs readfds writefds [] + else completeRequests reqs readfds writefds [] service_loop wakeup readfds writefds ptimeval reqs' delays' @@ -1065,13 +1140,13 @@ buildFdSets maxfd readfds writefds [] = return maxfd buildFdSets maxfd readfds writefds (Read fd m : reqs) | fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range" | otherwise = do - fdSet fd readfds + 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 + fdSet fd writefds + buildFdSets (max maxfd fd) readfds writefds reqs completeRequests [] _ _ reqs' = return reqs' completeRequests (Read fd m : reqs) readfds writefds reqs' = do @@ -1114,14 +1189,14 @@ getDelay now ptimeval [] = return ([],nullPtr) getDelay now ptimeval all@(d : rest) = case d of Delay time m | now >= time -> do - putMVar m () - getDelay now ptimeval rest + putMVar m () + getDelay now ptimeval rest DelaySTM time t | now >= time -> do - atomically $ writeTVar t True - getDelay now ptimeval rest + atomically $ writeTVar t True + getDelay now ptimeval rest _otherwise -> do - setTimevalTicks ptimeval (delayTime d - now) - return (all,ptimeval) + setTimevalTicks ptimeval (delayTime d - now) + return (all,ptimeval) newtype CTimeVal = CTimeVal () @@ -1180,4 +1255,44 @@ foreign import ccall unsafe "sizeof_fd_set" #endif +reportStackOverflow :: IO a +reportStackOverflow = do callStackOverflowHook; return undefined + +reportError :: SomeException -> IO a +reportError ex = do + handler <- getUncaughtExceptionHandler + handler ex + return undefined + +-- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove +-- the unsafe below. +foreign import ccall unsafe "stackOverflow" + callStackOverflowHook :: IO () + +{-# NOINLINE uncaughtExceptionHandler #-} +uncaughtExceptionHandler :: IORef (SomeException -> IO ()) +uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler) + where + defaultHandler :: SomeException -> IO () + defaultHandler se@(SomeException ex) = do + (hFlush stdout) `catchAny` (\ _ -> return ()) + let msg = case cast ex of + Just Deadlock -> "no threads to run: infinite loop or deadlock?" + _ -> case cast ex of + Just (ErrorCall s) -> s + _ -> showsPrec 0 se "" + withCString "%s" $ \cfmt -> + withCString msg $ \cmsg -> + errorBelch cfmt cmsg + +-- don't use errorBelch() directly, because we cannot call varargs functions +-- using the FFI. +foreign import ccall unsafe "HsBase.h errorBelch2" + errorBelch :: CString -> CString -> IO () + +setUncaughtExceptionHandler :: (SomeException -> IO ()) -> IO () +setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler + +getUncaughtExceptionHandler :: IO (SomeException -> IO ()) +getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler \end{code}