#ifndef mingw32_HOST_OS
import Data.Dynamic
-import Control.Monad
#endif
+import Control.Monad
import Data.Maybe
import GHC.Base
+#ifndef mingw32_HOST_OS
import GHC.Debug
+#endif
import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout )
import GHC.IO
#endif
import GHC.Pack ( packCString# )
import GHC.Show ( Show(..), showString )
-import GHC.Err
infixr 0 `par`, `pseq`
\end{code}
real_handler se@(SomeException ex) =
-- ignore thread GC and killThread exceptions:
case cast ex of
- Just BlockedOnDeadMVar -> return ()
+ Just BlockedIndefinitelyOnMVar -> return ()
_ -> case cast ex of
- Just BlockedIndefinitely -> return ()
+ Just BlockedIndefinitelyOnSTM -> return ()
_ -> case cast ex of
Just ThreadKilled -> return ()
_ -> case cast ex of
(\e -> do putMVar m a; throw e)
putMVar m a
return b
+
+modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
+modifyMVar_ m io =
+ block $ do
+ a <- takeMVar m
+ a' <- catchAny (unblock (io a))
+ (\e -> do putMVar m a; throw e)
+ putMVar m a'
+ return ()
\end{code}
%************************************************************************
-- around the scheduler loop. Furthermore, the scheduler can be simplified
-- by not having to check for completed IO requests.
--- 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.
---
--- - 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?
---
--- - 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
= Read {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ())
| DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool)
#ifndef mingw32_HOST_OS
+{-# NOINLINE pendingEvents #-}
pendingEvents :: IORef [IOReq]
+pendingEvents = unsafePerformIO $ newIORef []
#endif
-pendingDelays :: IORef [DelayReq]
- -- could use a strict list or array here
-{-# NOINLINE pendingEvents #-}
{-# NOINLINE pendingDelays #-}
-(pendingEvents,pendingDelays) = unsafePerformIO $ do
- startIOManagerThread
- reqs <- newIORef []
- dels <- newIORef []
- return (reqs, dels)
- -- the first time we schedule an IO request, the service thread
- -- will be created (cool, huh?)
+pendingDelays :: IORef [DelayReq]
+pendingDelays = unsafePerformIO $ newIORef []
+
+{-# NOINLINE ioManagerThread #-}
+ioManagerThread :: MVar (Maybe ThreadId)
+ioManagerThread = unsafePerformIO $ newMVar Nothing
ensureIOManagerIsRunning :: IO ()
ensureIOManagerIsRunning
- | threaded = seq pendingEvents $ return ()
+ | threaded = startIOManagerThread
| otherwise = return ()
+startIOManagerThread :: IO ()
+startIOManagerThread = do
+ modifyMVar_ ioManagerThread $ \old -> do
+ let create = do t <- forkIO ioManager; return (Just t)
+ case old of
+ Nothing -> create
+ Just t -> do
+ s <- threadStatus t
+ case s of
+ ThreadFinished -> create
+ ThreadDied -> create
+ _other -> return (Just t)
+
insertDelay :: DelayReq -> [DelayReq] -> [DelayReq]
insertDelay d [] = [d]
insertDelay d1 ds@(d2 : rest)
-- ----------------------------------------------------------------------------
-- Windows IO manager thread
-startIOManagerThread :: IO ()
-startIOManagerThread = do
+ioManager :: IO ()
+ioManager = do
wakeup <- c_getIOManagerEvent
- forkIO $ service_loop wakeup []
- return ()
+ service_loop wakeup []
service_loop :: HANDLE -- read end of pipe
-> [DelayReq] -- current delay requests
start_console_handler r =
case toWin32ConsoleEvent r of
Just x -> withMVar win32ConsoleHandler $ \handler -> do
- forkIO (handler x)
+ _ <- forkIO (handler x)
return ()
Nothing -> return ()
win32ConsoleHandler :: MVar (ConsoleEvent -> IO ())
win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler"))
--- XXX Is this actually needed?
-stick :: IORef HANDLE
-{-# NOINLINE stick #-}
-stick = unsafePerformIO (newIORef nullPtr)
-
wakeupIOManager :: IO ()
-wakeupIOManager = do
- _hdl <- readIORef stick
- c_sendIOManagerEvent io_MANAGER_WAKEUP
+wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP
-- Walk the queue of pending delays, waking up any that have passed
-- and return the smallest delay to wait for. The queue of pending
-- ----------------------------------------------------------------------------
-- Unix IO manager thread, using select()
-startIOManagerThread :: IO ()
-startIOManagerThread = do
+ioManager :: IO ()
+ioManager = do
allocaArray 2 $ \fds -> do
throwErrnoIfMinus1_ "startIOManagerThread" (c_pipe fds)
rd_end <- peekElemOff fds 0
setCloseOnExec wr_end
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 [] []
+ allocaBytes sizeofFdSet $ \readfds -> do
+ allocaBytes sizeofFdSet $ \writefds -> do
+ allocaBytes sizeofTimeVal $ \timeval -> do
+ service_loop (fromIntegral rd_end) readfds writefds timeval [] []
return ()
service_loop
-- | the stick is for poking the IO manager with
stick :: IORef Fd
{-# NOINLINE stick #-}
-stick = unsafePerformIO (newIORef 0)
+stick = unsafePerformIO $ newIORef (-1)
{-# NOINLINE sync #-}
sync :: IORef [MVar ()]
m <- newEmptyMVar
atomicModifyIORef sync (\old -> (m:old,()))
fd <- readIORef stick
- with io_MANAGER_SYNC $ \pbuf -> do
- warnErrnoIfMinus1_ "syncIOManager" $ c_write (fromIntegral fd) pbuf 1
+ when (fd /= (-1)) $
+ with io_MANAGER_SYNC $ \pbuf -> do
+ warnErrnoIfMinus1_ "syncIOManager" $ c_write (fromIntegral fd) pbuf 1
takeMVar m
wakeupIOManager :: IO ()
wakeupIOManager = do
fd <- readIORef stick
- with io_MANAGER_WAKEUP $ \pbuf -> do
- warnErrnoIfMinus1_ "wakeupIOManager" $ c_write (fromIntegral fd) pbuf 1
+ when (fd /= (-1)) $
+ with io_MANAGER_WAKEUP $ \pbuf -> do
+ warnErrnoIfMinus1_ "wakeupIOManager" $ c_write (fromIntegral fd) pbuf 1
-- For the non-threaded RTS
runHandlers :: Ptr Word8 -> Int -> IO ()
Just (f,_) -> do _ <- forkIO (f p_info)
return ()
+warnErrnoIfMinus1_ :: Num a => String -> IO a -> IO ()
+warnErrnoIfMinus1_ what io
+ = do r <- io
+ when (r == -1) $ do
+ errno <- getErrno
+ str <- strerror errno >>= peekCString
+ when (r == -1) $
+ debugErrLn ("Warning: " ++ what ++ " failed: " ++ str)
+
+foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar)
+
foreign import ccall "setIOManagerPipe"
c_setIOManagerPipe :: CInt -> IO ()
data CFdSet
-foreign import ccall safe "select"
+foreign import ccall safe "__hscore_select"
c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
-> IO CInt
#endif
-reportStackOverflow :: IO a
-reportStackOverflow = do callStackOverflowHook; return undefined
+reportStackOverflow :: IO ()
+reportStackOverflow = callStackOverflowHook
-reportError :: SomeException -> IO a
+reportError :: SomeException -> IO ()
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.
getUncaughtExceptionHandler :: IO (SomeException -> IO ())
getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
-warnErrnoIfMinus1_ :: Num a => String -> IO a -> IO ()
-warnErrnoIfMinus1_ what io
- = do r <- io
- when (r == -1) $ do
- errno <- getErrno
- str <- strerror errno >>= peekCString
- when (r == -1) $
- debugErrLn ("Warning: " ++ what ++ " failed: " ++ str)
-
-foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar)
-
\end{code}
projects / ghc-base.git / blobdiff