[commit: packages/base] ghc-7.8: Revert "Fix base component of #9423" (bfdf6bf)
git at git.haskell.org
git at git.haskell.org
Thu Nov 20 00:36:11 UTC 2014
Repository : ssh://git@git.haskell.org/base
On branch : ghc-7.8
Link : http://ghc.haskell.org/trac/ghc/changeset/bfdf6bf8f9487aae76cd939c00e6313cd68c208a/base
>---------------------------------------------------------------
commit bfdf6bf8f9487aae76cd939c00e6313cd68c208a
Author: Austin Seipp <austin at well-typed.com>
Date: Wed Nov 19 17:28:09 2014 -0600
Revert "Fix base component of #9423"
This reverts commit fb2cbec8ff8eb21690345aa5673c1936bf560fca.
Signed-off-by: Austin Seipp <austin at well-typed.com>
>---------------------------------------------------------------
bfdf6bf8f9487aae76cd939c00e6313cd68c208a
GHC/Event/Control.hs | 8 ++++++--
GHC/Event/Manager.hs | 1 -
GHC/Event/Thread.hs | 35 ++++++++++++++---------------------
GHC/Event/TimerManager.hs | 1 -
4 files changed, 20 insertions(+), 25 deletions(-)
diff --git a/GHC/Event/Control.hs b/GHC/Event/Control.hs
index 53a9bc8..2951a6a 100644
--- a/GHC/Event/Control.hs
+++ b/GHC/Event/Control.hs
@@ -17,7 +17,6 @@ module GHC.Event.Control
, readControlMessage
-- *** File descriptors
, controlReadFd
- , controlWriteFd
, wakeupReadFd
-- ** Control message sending
, sendWakeup
@@ -92,6 +91,7 @@ newControl shouldRegister = allocaArray 2 $ \fds -> do
setCloseOnExec wr
return (rd, wr)
(ctrl_rd, ctrl_wr) <- createPipe
+ when shouldRegister $ c_setIOManagerControlFd ctrl_wr
#if defined(HAVE_EVENTFD)
ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
setNonBlockingFD ev True
@@ -200,5 +200,9 @@ foreign import ccall unsafe "sys/eventfd.h eventfd_write"
c_eventfd_write :: CInt -> CULLong -> IO CInt
#endif
-foreign import ccall unsafe "setIOManagerWakeupFd"
+-- Used to tell the RTS how it can send messages to the I/O manager.
+foreign import ccall "setIOManagerControlFd"
+ c_setIOManagerControlFd :: CInt -> IO ()
+
+foreign import ccall "setIOManagerWakeupFd"
c_setIOManagerWakeupFd :: CInt -> IO ()
diff --git a/GHC/Event/Manager.hs b/GHC/Event/Manager.hs
index e474dc3..14f7098 100644
--- a/GHC/Event/Manager.hs
+++ b/GHC/Event/Manager.hs
@@ -27,7 +27,6 @@ module GHC.Event.Manager
-- * State
, callbackTableVar
- , emControl
-- * Registering interest in I/O events
, Event
diff --git a/GHC/Event/Thread.hs b/GHC/Event/Thread.hs
index c054742..c599047 100644
--- a/GHC/Event/Thread.hs
+++ b/GHC/Event/Thread.hs
@@ -21,7 +21,6 @@ import Data.List (zipWith3)
import Data.Maybe (Maybe(..))
import Data.Tuple (snd)
import Foreign.C.Error (eBADF, errnoToIOError)
-import Foreign.C.Types (CInt(..), CUInt(..))
import Foreign.Ptr (Ptr)
import GHC.Base
import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
@@ -33,14 +32,12 @@ import GHC.IO.Exception (ioError)
import GHC.IOArray (IOArray, newIOArray, readIOArray, writeIOArray,
boundsIOArray)
import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
-import GHC.Event.Control (controlWriteFd)
import GHC.Event.Internal (eventIs, evtClose)
import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
new, registerFd, unregisterFd_)
import qualified GHC.Event.Manager as M
import qualified GHC.Event.TimerManager as TM
import GHC.Num ((-), (+))
-import GHC.Real (fromIntegral)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Types (Fd)
@@ -256,11 +253,7 @@ startIOManagerThread :: IOArray Int (Maybe (ThreadId, EventManager))
startIOManagerThread eventManagerArray i = do
let create = do
!mgr <- new True
- !t <- forkOn i $ do
- c_setIOManagerControlFd
- (fromIntegral i)
- (fromIntegral $ controlWriteFd $ M.emControl mgr)
- loop mgr
+ !t <- forkOn i $ loop mgr
labelThread t "IOManager"
writeIOArray eventManagerArray i (Just (t,mgr))
old <- readIOArray eventManagerArray i
@@ -276,7 +269,6 @@ startIOManagerThread eventManagerArray i = do
-- the fork, for example. In this case we should clean up
-- open pipes and everything else related to the event manager.
-- See #4449
- c_setIOManagerControlFd (fromIntegral i) (-1)
M.cleanup em
create
_other -> return ()
@@ -285,10 +277,8 @@ startTimerManagerThread :: IO ()
startTimerManagerThread = modifyMVar_ timerManagerThreadVar $ \old -> do
let create = do
!mgr <- TM.new
- c_setTimerManagerControlFd
- (fromIntegral $ controlWriteFd $ TM.emControl mgr)
writeIORef timerManager $ Just mgr
- !t <- forkIO $ TM.loop mgr
+ !t <- forkIO $ TM.loop mgr `finally` shutdownManagers
labelThread t "TimerManager"
return $ Just t
case old of
@@ -306,11 +296,21 @@ startTimerManagerThread = modifyMVar_ timerManagerThreadVar $ \old -> do
mem <- readIORef timerManager
_ <- case mem of
Nothing -> return ()
- Just em -> do c_setTimerManagerControlFd (-1)
- TM.cleanup em
+ Just em -> TM.cleanup em
create
_other -> return st
+shutdownManagers :: IO ()
+shutdownManagers =
+ withMVar ioManagerLock $ \_ -> do
+ eventManagerArray <- readIORef eventManager
+ let (_, high) = boundsIOArray eventManagerArray
+ forM_ [0..high] $ \i -> do
+ mmgr <- readIOArray eventManagerArray i
+ case mmgr of
+ Nothing -> return ()
+ Just (_,mgr) -> M.shutdown mgr
+
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
ioManagerCapabilitiesChanged :: IO ()
@@ -344,10 +344,3 @@ ioManagerCapabilitiesChanged = do
Just (_,mgr) <- readIOArray eventManagerArray i
tid <- restartPollLoop mgr i
writeIOArray eventManagerArray i (Just (tid,mgr))
-
--- Used to tell the RTS how it can send messages to the I/O manager.
-foreign import ccall unsafe "setIOManagerControlFd"
- c_setIOManagerControlFd :: CUInt -> CInt -> IO ()
-
-foreign import ccall unsafe "setTimerManagerControlFd"
- c_setTimerManagerControlFd :: CInt -> IO ()
diff --git a/GHC/Event/TimerManager.hs b/GHC/Event/TimerManager.hs
index d8498aa..e52f1a0 100644
--- a/GHC/Event/TimerManager.hs
+++ b/GHC/Event/TimerManager.hs
@@ -15,7 +15,6 @@ module GHC.Event.TimerManager
, new
, newWith
, newDefaultBackend
- , emControl
-- * Running
, finished
More information about the ghc-commits
mailing list