Repository : ssh://darcs.haskell.org//srv/darcs/packages/base On branch : windows-iocp
http://hackage.haskell.org/trac/ghc/changeset/b107946f3febe57808e1b44dfa7d6621825f9615 >--------------------------------------------------------------- commit b107946f3febe57808e1b44dfa7d6621825f9615 Author: Joey Adams <[email protected]> Date: Sun Nov 18 01:13:35 2012 -0500 Add forkOSMasked to GHC.Conc.Sync Also, make rtsSupportsBoundThreads an unsafe foreign import, and move its definition to GHC.Conc.Sync. This breaks an import cycle, as the new Windows I/O manager will (likely) need forkOS. Importing it from Control.Concurrent produces a cycle: IO manager -> Control.Concurrent -> GHC.Conc.IO -> IO manager. forkOSMasked is defined in GHC.Conc.Sync, which has much fewer transitive dependencies. forkOSMasked is intended to be internal. That's why it's exported by GHC.Conc.Sync but not by Control.Concurrent. >--------------------------------------------------------------- Control/Concurrent.hs | 40 +++++++++------------------------------- GHC/Conc.lhs | 2 ++ GHC/Conc/Sync.lhs | 35 +++++++++++++++++++++++++++++++++++ GHC/ConsoleHandler.hs | 2 +- GHC/IO/FD.hs | 2 +- 5 files changed, 48 insertions(+), 33 deletions(-) diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs index 95ad957..58ab32e 100644 --- a/Control/Concurrent.hs +++ b/Control/Concurrent.hs @@ -263,12 +263,6 @@ waiting for the results in the main thread. -} --- | 'True' if bound threads are supported. --- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound' --- will always return 'False' and both 'forkOS' and 'runInBoundThread' will --- fail. -foreign import ccall rtsSupportsBoundThreads :: Bool - {- | Like 'forkIO', this sparks off a new thread to run the 'IO' @@ -302,35 +296,19 @@ forkOS_entry stableAction = do action <- deRefStablePtr stableAction action -foreign import ccall forkOS_createThread - :: StablePtr (IO ()) -> IO CInt - failNonThreaded :: IO a failNonThreaded = fail $ "RTS doesn't support multiple OS threads " ++"(use ghc -threaded when linking)" -forkOS action0 - | rtsSupportsBoundThreads = do - mv <- newEmptyMVar - b <- Exception.getMaskingState - let - -- async exceptions are masked in the child if they are masked - -- in the parent, as for forkIO (see #1048). forkOS_createThread - -- creates a thread with exceptions masked by default. - action1 = case b of - Unmasked -> unsafeUnmask action0 - MaskedInterruptible -> action0 - MaskedUninterruptible -> uninterruptibleMask_ action0 - - action_plus = Exception.catch action1 childHandler - - entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus) - err <- forkOS_createThread entry - when (err /= 0) $ fail "Cannot create OS thread." - tid <- takeMVar mv - freeStablePtr entry - return tid - | otherwise = failNonThreaded +forkOS action = do + b <- Exception.getMaskingState + forkOSMasked $ + -- async exceptions are masked in the child if they are masked + -- in the parent, as for forkIO (see #1048). + case b of + Unmasked -> unsafeUnmask action + MaskedInterruptible -> action + MaskedUninterruptible -> uninterruptibleMask_ action -- | Returns 'True' if the calling thread is /bound/, that is, if it is -- safe to use foreign libraries that rely on thread-local state from the diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index 914db3f..65d6492 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -37,6 +37,8 @@ module GHC.Conc , forkOnIO , forkOnIOUnmasked , forkOnWithUnmask + , rtsSupportsBoundThreads + , forkOSMasked , numCapabilities , getNumCapabilities , setNumCapabilities diff --git a/GHC/Conc/Sync.lhs b/GHC/Conc/Sync.lhs index ec266e9..dd9b262 100644 --- a/GHC/Conc/Sync.lhs +++ b/GHC/Conc/Sync.lhs @@ -47,6 +47,8 @@ module GHC.Conc.Sync , forkOnIO -- DEPRECATED , forkOnIOUnmasked , forkOnWithUnmask + , rtsSupportsBoundThreads + , forkOSMasked , numCapabilities , getNumCapabilities , setNumCapabilities @@ -272,6 +274,39 @@ forkOnIOUnmasked cpu io = forkOn cpu (unsafeUnmask io) forkOnWithUnmask :: Int -> ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId forkOnWithUnmask cpu io = forkOn cpu (io unsafeUnmask) +-- | 'True' if bound threads are supported. +-- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound' +-- will always return 'False' and both 'forkOS' and 'runInBoundThread' will +-- fail. +foreign import ccall unsafe rtsSupportsBoundThreads :: Bool + +-- | Like 'Control.Concurrent.forkOS', but start the thread in +-- 'Control.Exception.MaskedInterruptible', rather than inheriting the masking +-- state from the caller. +forkOSMasked :: IO () -> IO ThreadId + +foreign import ccall forkOS_createThread + :: StablePtr (IO ()) -> IO CInt + +failNonThreaded :: IO a +failNonThreaded = fail $ "RTS doesn't support multiple OS threads " + ++"(use ghc -threaded when linking)" + +forkOSMasked action + | rtsSupportsBoundThreads = do + mv <- newEmptyMVar + entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus) + err <- forkOS_createThread entry + -- forkOS_createThread creates a thread with exceptions + -- masked by default. + when (err /= 0) $ fail "Cannot create OS thread." + tid <- takeMVar mv + freeStablePtr entry + return tid + | otherwise = failNonThreaded + where + action_plus = catchException action childHandler + -- | the value passed to the @+RTS -N@ flag. This is the number of -- Haskell threads that can run truly simultaneously at any given -- time, and is typically set to the number of physical processor cores on diff --git a/GHC/ConsoleHandler.hs b/GHC/ConsoleHandler.hs index 95810d6..98c55d0 100644 --- a/GHC/ConsoleHandler.hs +++ b/GHC/ConsoleHandler.hs @@ -133,7 +133,7 @@ installHandler handler no_handler = error "win32ConsoleHandler" -foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent" rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs index 0f37a81..536c19c 100644 --- a/GHC/IO/FD.hs +++ b/GHC/IO/FD.hs @@ -638,7 +638,7 @@ foreign import WINDOWS_CCONV safe "send" #endif -foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool -- ----------------------------------------------------------------------------- -- utils _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
