From 2ed4c3ce3514e619281352cb8a6a5e7369b00421 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Fri, 6 Nov 2009 14:06:29 +0000 Subject: [PATCH] Rollback #1185 fix rolling back: Tue Nov 3 16:05:40 GMT 2009 Simon Marlow * Fix #1185: restart the IO manager after fork() This is the libraries/base part of the patch; there is a corresponding patch to GHC itself. The main change is that we now keep track of the IO manager's ThreadId in a top-level MVar, and ensureIOManagerIsRunning checks whether a previous IO manager thread is alive before starting one. In the child of fork(), we can hence call ensureIOManagerIsRunning to restart the IO manager. M ./GHC/Conc.lhs -46 +44 Wed Nov 4 17:49:45 GMT 2009 Ian Lynagh * Fix the build on Windows M ./GHC/Conc.lhs -6 +4 --- GHC/Conc.lhs | 100 ++++++++++++++++++++++++++++++---------------------------- 1 file changed, 52 insertions(+), 48 deletions(-) diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index 22bf113..7f7d585 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -608,15 +608,6 @@ withMVar m io = (\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} %************************************************************************ @@ -754,6 +745,23 @@ calculateTarget usecs = do -- 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 ()) @@ -765,36 +773,25 @@ data DelayReq | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool) #ifndef mingw32_HOST_OS -{-# NOINLINE pendingEvents #-} pendingEvents :: IORef [IOReq] -pendingEvents = unsafePerformIO $ newIORef [] #endif -{-# NOINLINE pendingDelays #-} pendingDelays :: IORef [DelayReq] -pendingDelays = unsafePerformIO $ newIORef [] - -{-# NOINLINE ioManagerThread #-} -ioManagerThread :: MVar (Maybe ThreadId) -ioManagerThread = unsafePerformIO $ newMVar Nothing + -- 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?) ensureIOManagerIsRunning :: IO () ensureIOManagerIsRunning - | threaded = startIOManagerThread + | threaded = seq pendingEvents $ return () | 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) @@ -823,10 +820,11 @@ prodServiceThread = do -- ---------------------------------------------------------------------------- -- Windows IO manager thread -ioManager :: IO () -ioManager = do +startIOManagerThread :: IO () +startIOManagerThread = do wakeup <- c_getIOManagerEvent - service_loop wakeup [] + _ <- forkIO $ service_loop wakeup [] + return () service_loop :: HANDLE -- read end of pipe -> [DelayReq] -- current delay requests @@ -896,8 +894,15 @@ toWin32ConsoleEvent ev = 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 = c_sendIOManagerEvent io_MANAGER_WAKEUP +wakeupIOManager = do + _hdl <- readIORef stick + 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 @@ -946,8 +951,8 @@ foreign import stdcall "WaitForSingleObject" -- ---------------------------------------------------------------------------- -- Unix IO manager thread, using select() -ioManager :: IO () -ioManager = do +startIOManagerThread :: IO () +startIOManagerThread = do allocaArray 2 $ \fds -> do throwErrnoIfMinus1_ "startIOManagerThread" (c_pipe fds) rd_end <- peekElemOff fds 0 @@ -958,10 +963,11 @@ ioManager = do setCloseOnExec wr_end writeIORef stick (fromIntegral wr_end) c_setIOManagerPipe wr_end - allocaBytes sizeofFdSet $ \readfds -> do - allocaBytes sizeofFdSet $ \writefds -> do - allocaBytes sizeofTimeVal $ \timeval -> do - service_loop (fromIntegral rd_end) readfds writefds timeval [] [] + _ <- 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 @@ -1059,7 +1065,7 @@ io_MANAGER_SYNC = 0xfd -- | the stick is for poking the IO manager with stick :: IORef Fd {-# NOINLINE stick #-} -stick = unsafePerformIO $ newIORef (-1) +stick = unsafePerformIO (newIORef 0) {-# NOINLINE sync #-} sync :: IORef [MVar ()] @@ -1071,17 +1077,15 @@ syncIOManager = do m <- newEmptyMVar atomicModifyIORef sync (\old -> (m:old,())) fd <- readIORef stick - when (fd /= (-1)) $ - with io_MANAGER_SYNC $ \pbuf -> do - warnErrnoIfMinus1_ "syncIOManager" $ c_write (fromIntegral fd) pbuf 1 + with io_MANAGER_SYNC $ \pbuf -> do + warnErrnoIfMinus1_ "syncIOManager" $ c_write (fromIntegral fd) pbuf 1 takeMVar m wakeupIOManager :: IO () wakeupIOManager = do fd <- readIORef stick - when (fd /= (-1)) $ - with io_MANAGER_WAKEUP $ \pbuf -> do - warnErrnoIfMinus1_ "wakeupIOManager" $ c_write (fromIntegral fd) pbuf 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 () -- 1.7.10.4