[commit: packages/base] ghc-7.8: Fix base component of #9423 (fb2cbec)
git at git.haskell.org
git at git.haskell.org
Wed Nov 5 19:02:35 UTC 2014
Repository : ssh://git@git.haskell.org/base
On branch : ghc-7.8
Link : http://ghc.haskell.org/trac/ghc/changeset/fb2cbec8ff8eb21690345aa5673c1936bf560fca/base
>---------------------------------------------------------------
commit fb2cbec8ff8eb21690345aa5673c1936bf560fca
Author: Andreas Voellmy <andreas.voellmy at gmail.com>
Date: Mon Nov 3 09:57:33 2014 -0600
Fix base component of #9423
Signed-off-by: Austin Seipp <austin at well-typed.com>
>---------------------------------------------------------------
fb2cbec8ff8eb21690345aa5673c1936bf560fca
GHC/Event/Control.hs | 8 ++------
GHC/Event/Manager.hs | 1 +
GHC/Event/Thread.hs | 35 +++++++++++++++++++++--------------
GHC/Event/TimerManager.hs | 1 +
4 files changed, 25 insertions(+), 20 deletions(-)
diff --git a/GHC/Event/Control.hs b/GHC/Event/Control.hs
index 2951a6a..53a9bc8 100644
--- a/GHC/Event/Control.hs
+++ b/GHC/Event/Control.hs
@@ -17,6 +17,7 @@ module GHC.Event.Control
, readControlMessage
-- *** File descriptors
, controlReadFd
+ , controlWriteFd
, wakeupReadFd
-- ** Control message sending
, sendWakeup
@@ -91,7 +92,6 @@ 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,9 +200,5 @@ foreign import ccall unsafe "sys/eventfd.h eventfd_write"
c_eventfd_write :: CInt -> CULLong -> IO CInt
#endif
--- 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"
+foreign import ccall unsafe "setIOManagerWakeupFd"
c_setIOManagerWakeupFd :: CInt -> IO ()
diff --git a/GHC/Event/Manager.hs b/GHC/Event/Manager.hs
index 14f7098..e474dc3 100644
--- a/GHC/Event/Manager.hs
+++ b/GHC/Event/Manager.hs
@@ -27,6 +27,7 @@ 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 c599047..c054742 100644
--- a/GHC/Event/Thread.hs
+++ b/GHC/Event/Thread.hs
@@ -21,6 +21,7 @@ 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,
@@ -32,12 +33,14 @@ 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)
@@ -253,7 +256,11 @@ startIOManagerThread :: IOArray Int (Maybe (ThreadId, EventManager))
startIOManagerThread eventManagerArray i = do
let create = do
!mgr <- new True
- !t <- forkOn i $ loop mgr
+ !t <- forkOn i $ do
+ c_setIOManagerControlFd
+ (fromIntegral i)
+ (fromIntegral $ controlWriteFd $ M.emControl mgr)
+ loop mgr
labelThread t "IOManager"
writeIOArray eventManagerArray i (Just (t,mgr))
old <- readIOArray eventManagerArray i
@@ -269,6 +276,7 @@ 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 ()
@@ -277,8 +285,10 @@ 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 `finally` shutdownManagers
+ !t <- forkIO $ TM.loop mgr
labelThread t "TimerManager"
return $ Just t
case old of
@@ -296,21 +306,11 @@ startTimerManagerThread = modifyMVar_ timerManagerThreadVar $ \old -> do
mem <- readIORef timerManager
_ <- case mem of
Nothing -> return ()
- Just em -> TM.cleanup em
+ Just em -> do c_setTimerManagerControlFd (-1)
+ 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,3 +344,10 @@ 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 e52f1a0..d8498aa 100644
--- a/GHC/Event/TimerManager.hs
+++ b/GHC/Event/TimerManager.hs
@@ -15,6 +15,7 @@ module GHC.Event.TimerManager
, new
, newWith
, newDefaultBackend
+ , emControl
-- * Running
, finished
More information about the ghc-commits
mailing list