From: wolfgang Date: Sun, 21 Sep 2003 22:20:57 +0000 (+0000) Subject: [project @ 2003-09-21 22:20:57 by wolfgang] X-Git-Tag: nhc98-1-18-release~506 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e7ddb1da757db6a5898d252e9aead0282965b405;p=haskell-directory.git [project @ 2003-09-21 22:20:57 by wolfgang] Bound Threads ============= Introduce a way to use foreign libraries that rely on thread local state from multiple threads (mainly affects the threaded RTS). See the file threads.tex in CVS at haskell-report/ffi/threads.tex (not entirely finished yet) for a definition of this extension. A less formal description is also found in the documentation of Control.Concurrent. The changes mostly affect the THREADED_RTS (./configure --enable-threaded-rts), except for saving & restoring errno on a per-TSO basis, which is also necessary for the non-threaded RTS (a bugfix). Detailed list of changes ------------------------ - errno is saved in the TSO object and restored when necessary: ghc/includes/TSO.h, ghc/rts/Interpreter.c, ghc/rts/Schedule.c - rts_mainLazyIO is no longer needed, main is no special case anymore ghc/includes/RtsAPI.h, ghc/rts/RtsAPI.c, ghc/rts/Main.c, ghc/rts/Weak.c - passCapability: a new function that releases the capability and "passes" it to a specific OS thread: ghc/rts/Capability.h ghc/rts/Capability.c - waitThread(), scheduleWaitThread() and schedule() get an optional Capability *initialCapability passed as an argument: ghc/includes/SchedAPI.h, ghc/rts/Schedule.c, ghc/rts/RtsAPI.c - Bound Thread scheduling (that's what this is all about): ghc/rts/Schedule.h, ghc/rts/Schedule.c - new Primop isCurrentThreadBound#: ghc/compiler/prelude/primops.txt.pp, ghc/includes/PrimOps.h, ghc/rts/PrimOps.hc, ghc/rts/Schedule.h, ghc/rts/Schedule.c - a simple function, rtsSupportsBoundThreads, that returns true if THREADED_RTS is defined: ghc/rts/Schedule.h, ghc/rts/Schedule.c - a new implementation of forkProcess (the old implementation stays in place for the non-threaded case). Partially broken; works for the standard fork-and-exec case, but not for much else. A proper forkProcess is really next to impossible to implement: ghc/rts/Schedule.c - Library support for bound threads: Control.Concurrent. rtsSupportsBoundThreads, isCurrentThreadBound, forkOS, runInBoundThread, runInUnboundThread libraries/base/Control/Concurrent.hs, libraries/base/Makefile, libraries/base/include/HsBase.h, libraries/base/cbits/forkOS.c (new file) --- diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs index 451e4f9..e354c43 100644 --- a/Control/Concurrent.hs +++ b/Control/Concurrent.hs @@ -62,6 +62,15 @@ module Control.Concurrent ( #endif -- $merge + -- * Bound Threads + -- $boundthreads +#ifdef __GLASGOW_HASKELL__ + rtsSupportsBoundThreads, + forkOS, + isCurrentThreadBound, + runInBoundThread +#endif + -- * GHC's implementation of concurrency -- |This section describes features specific to GHC's @@ -74,7 +83,6 @@ module Control.Concurrent ( -- ** Pre-emption -- $preemption - ) where import Prelude @@ -86,7 +94,12 @@ import GHC.Conc import GHC.TopHandler ( reportStackOverflow, reportError ) import GHC.IOBase ( IO(..) ) import GHC.IOBase ( unsafeInterleaveIO ) +import GHC.IOBase ( newIORef, readIORef, writeIORef ) import GHC.Base + +import Foreign.StablePtr +import Foreign.C.Types ( CInt ) +import Control.Monad ( when ) #endif #ifdef __HUGS__ @@ -114,6 +127,10 @@ and context switching overheads are extremely low. Scheduling of Haskell threads is done internally in the Haskell runtime system, and doesn't make use of any operating system-supplied thread packages. +However, if you want to interact with a foreign library that expects your +program to use the operating system-supplied thread package, you can do so +by using 'forkOS' instead of 'forkIO'. + Haskell threads can communicate via 'MVar's, a kind of synchronised mutable variable (see "Control.Concurrent.MVar"). Several common concurrency abstractions can be built from 'MVar's, and these are @@ -189,6 +206,9 @@ instance Show ThreadId where 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. + +The new thread will be a lightweight thread; if you want to use a foreign +library that uses thread-local storage, use 'forkOS' instead. -} forkIO :: IO () -> IO ThreadId forkIO action = IO $ \ s -> @@ -288,6 +308,158 @@ nmergeIO lss #endif /* __HUGS__ */ -- --------------------------------------------------------------------------- +-- Bound Threads + +{- $boundthreads + +Support for multiple operating system threads and bound threads as described +below is currently only available in the GHC runtime system when the runtime system +has been compiled using a special option. + +When recompiling GHC, use ./configure --enable-threaded-rts to enable this. +To find your GHC has already been compiled that way, use +'rtsSupportsBoundThreads' from GHCi. + +Other Haskell systems do not currently support multiple operating system threads. + +A bound thread is a haskell thread that is /bound/ to an operating system +thread. While the bound thread is still scheduled by the Haskell run-time +system, the operating system thread takes care of all the foreign calls made +by the bound thread. + +To a foreign library, the bound thread will look exactly like an ordinary +operating system thread created using OS functions like @pthread_create@ +or @CreateThread@. + +Bound threads can be created using the 'forkOS' function below. All foreign +exported functions are run in a bound thread (bound to the OS thread that +called the function). Also, the @main@ action of every Haskell program is +run in a bound thread. + +Why do we need this? Because if a foreign library is called from a thread +created using 'forkIO', it won't have access to any /thread-local state/ - +state variables that have specific values for each OS thread +(see POSIX's @pthread_key_create@ or Win32's @TlsAlloc@). Therefore, some +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@. +-} + +#ifdef + __GLASGOW_HASKELL__ + +-- | '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' 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'. +-} +forkOS :: IO () -> IO ThreadId + +foreign export ccall forkOS_entry + :: StablePtr (IO ()) -> IO () + +foreign import ccall "forkOS_entry" forkOS_entry_reimported + :: StablePtr (IO ()) -> IO () + +forkOS_entry stableAction = do + action <- deRefStablePtr stableAction + action + +foreign import ccall forkOS_createThread + :: StablePtr (IO ()) -> IO CInt + +forkOS action + | rtsSupportsBoundThreads = do + mv <- newEmptyMVar + let action_plus = Exception.catch action 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 = fail "RTS not built to support multiple OS threads." + +-- | 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 +-- calling thread. +isCurrentThreadBound :: IO Bool +isCurrentThreadBound = IO $ \ s# -> + case isCurrentThreadBound# s# of + (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #) + + +{- | +Run the 'IO' computation passed as the first argument. If the calling thread +is not /bound/, a bound thread is created temporarily. @runInBoundThread@ +doesn't finish until the 'IO' computation finishes. + +You can wrap a series of foreign function calls that rely on thread-local state +with @runInBoundThread@ so that you can use them without knowing whether the +current thread is /bound/. +-} +runInBoundThread :: IO a -> IO a + +runInBoundThread action + | rtsSupportsBoundThreads = do + bound <- isCurrentThreadBound + if bound + then 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 + | otherwise = fail "RTS not built to support multiple OS threads." + +{- | +Run the 'IO' computation passed as the first argument. If the calling thread +is /bound/, an unbound thread is created temporarily using 'forkIO'. +@runInBoundThread@ doesn't finish until the 'IO' computation finishes. + +Use this function /only/ in the rare case that you have actually observed a +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@. +-} +runInUnboundThread :: IO a -> IO a + +runInUnboundThread action = do + bound <- isCurrentThreadBound + if bound + then do + mv <- newEmptyMVar + forkIO (E.try action >>= putMVar mv) + takeMVar mv >>= \either -> case either of + Left exception -> E.throw exception + Right result -> return result + else action + +#endif + +-- --------------------------------------------------------------------------- -- More docs {- $termination diff --git a/Makefile b/Makefile index b64e054..a557fe1 100644 --- a/Makefile +++ b/Makefile @@ -71,6 +71,14 @@ boot :: GHC/PrimopWrappers.hs EXTRA_SRCS += GHC/PrimopWrappers.hs CLEAN_FILES += GHC/PrimopWrappers.hs +# ----------------------------------------------------------------------------- + +STUBOBJS += \ + Control/Concurrent_stub.$(way_)o + +CLEAN_FILES += $(STUBOBJS) \ + Control/Concurrent_stub.[ch] + #----------------------------------------------------------------------------- # Building the library for GHCi # diff --git a/cbits/forkOS.c b/cbits/forkOS.c new file mode 100644 index 0000000..eb0ad0c --- /dev/null +++ b/cbits/forkOS.c @@ -0,0 +1,59 @@ +/* + * (c) The GHC Team 2003 + * + * $Id: forkOS.c,v 1.1 2003/09/21 22:20:57 wolfgang Exp $ + * + * Helper function for Control.Concurrent.forkOS + */ + +#include "HsBase.h" +#include "RtsAPI.h" + +#if defined(HAVE_PTHREAD_H) && !defined(WANT_NATIVE_WIN32_THREADS) +#include + +static void * +forkOS_createThreadWrapper ( void * entry ) +{ + rts_lock(); + rts_evalStableIO((HsStablePtr) entry, NULL); + rts_unlock(); + return NULL; +} + +int +forkOS_createThread ( HsStablePtr entry ) +{ + pthread_t tid; + int result = pthread_create(&tid, NULL, + forkOS_createThreadWrapper, (void*)entry); + if(!result) + pthread_detach(tid); + return result; +} + +#elif defined(HAVE_WINDOWS_H) +#include + +static unsigned __stdcall +forkOS_createThreadWrapper ( void * entry ) +{ + rts_lock(); + rts_evalStableIO((HsStablePtr) entry, NULL); + rts_unlock(); + return 0; +} + +int +forkOS_createThread ( HsStablePtr entry ) +{ + return (_beginthreadex ( NULL, /* default security attributes */ + 0, + forkOS_createThreadWrapper, + (void*)entry, + 0, + (unsigned*)pId) == 0); +} + +#else +#endif \ No newline at end of file diff --git a/include/HsBase.h b/include/HsBase.h index 019f491..e091f14 100644 --- a/include/HsBase.h +++ b/include/HsBase.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: HsBase.h,v 1.26 2003/09/12 12:29:44 simonmar Exp $ + * $Id: HsBase.h,v 1.27 2003/09/21 22:20:57 wolfgang Exp $ * * (c) The University of Glasgow 2001-2002 * @@ -129,6 +129,9 @@ int inputReady(int fd, int msecs, int isSock); /* in writeError.c */ void writeErrString__(HsAddr msg_hdr, HsAddr msg, HsInt len); +/* in forkOS.c */ +int forkOS_createThread ( HsStablePtr entry ); + /* in Signals.c */ extern HsInt nocldstop;