X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Control%2FConcurrent.hs;h=62a30b434889b0cdd1e410d2c10275d740d85b65;hb=7dbb606d7b57cdad87a0ffbdb6ea4a274ebca7c0;hp=aa40b81e40195d0adcc239768fe53235ea14c82a;hpb=ea7f925de8c7bd879d20dcb9ce9dd8da9e6e8855;p=ghc-base.git diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs index aa40b81..62a30b4 100644 --- a/Control/Concurrent.hs +++ b/Control/Concurrent.hs @@ -1,3 +1,11 @@ +{-# LANGUAGE CPP + , ForeignFunctionInterface + , MagicHash + , UnboxedTuples + , ScopedTypeVariables + #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent @@ -27,10 +35,17 @@ module Control.Concurrent ( forkIO, #ifdef __GLASGOW_HASKELL__ + forkIOWithUnmask, killThread, throwTo, #endif + -- ** Threads with affinity + forkOn, + forkOnWithUnmask, + getNumCapabilities, + threadCapability, + -- * Scheduling -- $conc_scheduling @@ -69,7 +84,7 @@ module Control.Concurrent ( forkOS, isCurrentThreadBound, runInBoundThread, - runInUnboundThread + runInUnboundThread, #endif -- * GHC's implementation of concurrency @@ -88,20 +103,22 @@ module Control.Concurrent ( -- ** Pre-emption -- $preemption + + -- * Deprecated functions + forkIOUnmasked + ) where import Prelude -import Control.Exception as Exception +import Control.Exception.Base as Exception #ifdef __GLASGOW_HASKELL__ -import GHC.Conc ( ThreadId(..), myThreadId, killThread, yield, - threadDelay, forkIO, childHandler ) +import GHC.Exception +import GHC.Conc hiding (threadWaitRead, threadWaitWrite) import qualified GHC.Conc -import GHC.TopHandler ( reportStackOverflow, reportError ) -import GHC.IOBase ( IO(..) ) -import GHC.IOBase ( unsafeInterleaveIO ) -import GHC.IOBase ( newIORef, readIORef, writeIORef ) +import GHC.IO ( IO(..), unsafeInterleaveIO, unsafeUnmask ) +import GHC.IORef ( newIORef, readIORef, writeIORef ) import GHC.Base import System.Posix.Types ( Fd ) @@ -112,7 +129,6 @@ import Control.Monad ( when ) #ifdef mingw32_HOST_OS import Foreign.C import System.IO -import GHC.Handle #endif #endif @@ -292,6 +308,21 @@ state variables that have specific values for each OS thread libraries (OpenGL, for example) will not work from a thread created using 'forkIO'. They work fine in threads created using 'forkOS' or when called from @main@ or from a @foreign export@. + +In terms of performance, 'forkOS' (aka bound) threads are much more +expensive than 'forkIO' (aka unbound) threads, because a 'forkOS' +thread is tied to a particular OS thread, whereas a 'forkIO' thread +can be run by any OS thread. Context-switching between a 'forkOS' +thread and a 'forkIO' thread is many times more expensive than between +two 'forkIO' threads. + +Note in particular that the main program thread (the thread running +@Main.main@) is always a bound thread, so for good concurrency +performance you should ensure that the main thread is not doing +repeated communication with other threads in the system. Typically +this means forking subthreads to do the work using 'forkIO', and +waiting for the results in the main thread. + -} -- | 'True' if bound threads are supported. @@ -301,29 +332,25 @@ from @main@ or from a @foreign export@. foreign import ccall rtsSupportsBoundThreads :: Bool -{- | -Like 'forkIO', this sparks off a new thread to run the 'IO' computation passed as the -first argument, and returns the 'ThreadId' of the newly created -thread. - -However, @forkOS@ uses operating system-supplied multithreading support to create -a new operating system thread. The new thread is /bound/, which means that -all foreign calls made by the 'IO' computation are guaranteed to be executed -in this new operating system thread; also, the operating system thread is not -used for any other foreign calls. - -This means that you can use all kinds of foreign libraries from this thread -(even those that rely on thread-local state), without the limitations of 'forkIO'. - -Just to clarify, 'forkOS' is /only/ necessary if you need to associate -a Haskell thread with a particular OS thread. It is not necessary if -you only need to make non-blocking foreign calls (see -"Control.Concurrent#osthreads"). Neither is it necessary if you want -to run threads in parallel on a multiprocessor: threads created with -'forkIO' will be shared out amongst the running CPUs (using GHC, -@-threaded@, and the @+RTS -N@ runtime option). - +{- | +Like 'forkIO', this sparks off a new thread to run the 'IO' +computation passed as the first argument, and returns the 'ThreadId' +of the newly created thread. + +However, 'forkOS' creates a /bound/ thread, which is necessary if you +need to call foreign (non-Haskell) libraries that make use of +thread-local state, such as OpenGL (see "Control.Concurrent#boundthreads"). + +Using 'forkOS' instead of 'forkIO' makes no difference at all to the +scheduling behaviour of the Haskell runtime system. It is a common +misconception that you need to use 'forkOS' instead of 'forkIO' to +avoid blocking all the Haskell threads when making a foreign call; +this isn't the case. To allow foreign calls to be made without +blocking all the Haskell threads (with GHC), it is only necessary to +use the @-threaded@ option when linking your program, and to make sure +the foreign import is not marked @unsafe@. -} + forkOS :: IO () -> IO ThreadId foreign export ccall forkOS_entry @@ -332,6 +359,7 @@ foreign export ccall forkOS_entry foreign import ccall "forkOS_entry" forkOS_entry_reimported :: StablePtr (IO ()) -> IO () +forkOS_entry :: StablePtr (IO ()) -> IO () forkOS_entry stableAction = do action <- deRefStablePtr stableAction action @@ -339,13 +367,25 @@ forkOS_entry stableAction = do 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 action +forkOS action0 | rtsSupportsBoundThreads = do mv <- newEmptyMVar - let action_plus = Exception.catch action childHandler + 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." @@ -382,13 +422,10 @@ runInBoundThread action else do ref <- newIORef undefined let action_plus = Exception.try action >>= writeIORef ref - resultOrException <- - bracket (newStablePtr action_plus) - freeStablePtr - (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref) - case resultOrException of - Left exception -> Exception.throw exception - Right result -> return result + bracket (newStablePtr action_plus) + freeStablePtr + (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref) >>= + unsafeResult | otherwise = failNonThreaded {- | @@ -401,27 +438,40 @@ performance loss due to the use of bound threads. A program that doesn't need it's main thread to be bound and makes /heavy/ use of concurrency (e.g. a web server), might want to wrap it's @main@ action in @runInUnboundThread@. + +Note that exceptions which are thrown to the current thread are thrown in turn +to the thread that is executing the given computation. This ensures there's +always a way of killing the forked thread. -} runInUnboundThread :: IO a -> IO a runInUnboundThread action = do - bound <- isCurrentThreadBound - if bound - then do - mv <- newEmptyMVar - forkIO (Exception.try action >>= putMVar mv) - takeMVar mv >>= \either -> case either of - Left exception -> Exception.throw exception - Right result -> return result - else action - + bound <- isCurrentThreadBound + if bound + then do + mv <- newEmptyMVar + mask $ \restore -> do + tid <- forkIO $ Exception.try (restore action) >>= putMVar mv + let wait = takeMVar mv `Exception.catch` \(e :: SomeException) -> + Exception.throwTo tid e >> wait + wait >>= unsafeResult + else action + +unsafeResult :: Either SomeException a -> IO a +unsafeResult = either Exception.throwIO return #endif /* __GLASGOW_HASKELL__ */ +#ifdef __GLASGOW_HASKELL__ -- --------------------------------------------------------------------------- -- threadWaitRead/threadWaitWrite -- | Block the current thread until data is available to read on the -- given file descriptor (GHC only). +-- +-- This will throw an 'IOError' if the file descriptor was closed +-- while this thread was blocked. To safely close a file descriptor +-- that has been used with 'threadWaitRead', use +-- 'GHC.Conc.closeFdWith'. threadWaitRead :: Fd -> IO () threadWaitRead fd #ifdef mingw32_HOST_OS @@ -431,7 +481,8 @@ threadWaitRead fd -- and this only works with -threaded. | threaded = withThread (waitFd fd 0) | otherwise = case fd of - 0 -> do hWaitForInput stdin (-1); return () + 0 -> do _ <- hWaitForInput stdin (-1) + return () -- hWaitForInput does work properly, but we can only -- do this for stdin since we know its FD. _ -> error "threadWaitRead requires -threaded on Windows, or use System.IO.hWaitForInput" @@ -441,6 +492,11 @@ threadWaitRead fd -- | Block the current thread until data can be written to the -- given file descriptor (GHC only). +-- +-- This will throw an 'IOError' if the file descriptor was closed +-- while this thread was blocked. To safely close a file descriptor +-- that has been used with 'threadWaitWrite', use +-- 'GHC.Conc.closeFdWith'. threadWaitWrite :: Fd -> IO () threadWaitWrite fd #ifdef mingw32_HOST_OS @@ -456,19 +512,19 @@ foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool withThread :: IO a -> IO a withThread io = do m <- newEmptyMVar - forkIO $ try io >>= putMVar m + _ <- mask_ $ forkIO $ try io >>= putMVar m x <- takeMVar m case x of Right a -> return a - Left e -> throwIO e + Left e -> throwIO (e :: IOException) waitFd :: Fd -> CInt -> IO () waitFd fd write = do - throwErrnoIfMinus1 "fdReady" $ - fdReady (fromIntegral fd) write (fromIntegral iNFINITE) 0 - return () + throwErrnoIfMinus1_ "fdReady" $ + fdReady (fromIntegral fd) write iNFINITE 0 -iNFINITE = 0xFFFFFFFF :: CInt -- urgh +iNFINITE :: CInt +iNFINITE = 0xFFFFFFFF -- urgh foreign import ccall safe "fdReady" fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt @@ -500,7 +556,7 @@ foreign import ccall safe "fdReady" The "System.IO" library manages multiplexing in its own way. On Windows systems it uses @safe@ foreign calls to ensure that threads doing I\/O operations don't block the whole runtime, - whereas on Unix systems all the currently blocked I\/O reqwests + whereas on Unix systems all the currently blocked I\/O requests are managed by a single thread (the /IO manager thread/) using @select@. @@ -608,3 +664,4 @@ foreign import ccall safe "fdReady" lock is woken up, but haven't found it to be useful for anything other than this example :-) -} +#endif /* __GLASGOW_HASKELL__ */