+#ifdef __GLASGOW_HASKELL__
+-- ---------------------------------------------------------------------------
+-- Bound Threads
+
+{- $boundthreads
+ #boundthreads#
+
+Support for multiple operating system threads and bound threads as described
+below is currently only available in the GHC runtime system if you use the
+/-threaded/ option when linking.
+
+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@.
+
+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.
+-- 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' 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
+ :: StablePtr (IO ()) -> IO ()
+
+foreign import ccall "forkOS_entry" forkOS_entry_reimported
+ :: StablePtr (IO ()) -> IO ()
+
+forkOS_entry :: StablePtr (IO ()) -> IO ()
+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.blocked
+ let
+ -- async exceptions are blocked in the child if they are blocked
+ -- in the parent, as for forkIO (see #1048). forkOS_createThread
+ -- creates a thread with exceptions blocked by default.
+ action1 | b = action0
+ | otherwise = unblock 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
+
+-- | 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 :: SomeException)
+ Right result -> return result
+ | otherwise = failNonThreaded
+
+{- |
+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 (Exception.try action >>= putMVar mv)
+ takeMVar mv >>= \ei -> case ei of
+ Left exception -> Exception.throw (exception :: SomeException)
+ Right result -> return result
+ else action
+
+#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).
+threadWaitRead :: Fd -> IO ()
+threadWaitRead fd
+#ifdef mingw32_HOST_OS
+ -- we have no IO manager implementing threadWaitRead on Windows.
+ -- fdReady does the right thing, but we have to call it in a
+ -- separate thread, otherwise threadWaitRead won't be interruptible,
+ -- and this only works with -threaded.
+ | threaded = withThread (waitFd fd 0)
+ | otherwise = case fd of
+ 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"
+#else
+ = GHC.Conc.threadWaitRead fd
+#endif
+
+-- | Block the current thread until data can be written to the
+-- given file descriptor (GHC only).
+threadWaitWrite :: Fd -> IO ()
+threadWaitWrite fd
+#ifdef mingw32_HOST_OS
+ | threaded = withThread (waitFd fd 1)
+ | otherwise = error "threadWaitWrite requires -threaded on Windows"
+#else
+ = GHC.Conc.threadWaitWrite fd
+#endif
+
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
+
+withThread :: IO a -> IO a
+withThread io = do
+ m <- newEmptyMVar
+ forkIO $ try io >>= putMVar m
+ x <- takeMVar m
+ case x of
+ Right a -> return a
+ Left e -> throwIO (e :: IOException)
+
+waitFd :: Fd -> CInt -> IO ()
+waitFd fd write = do
+ throwErrnoIfMinus1 "fdReady" $
+ fdReady (fromIntegral fd) write (fromIntegral iNFINITE) 0
+ return ()
+
+iNFINITE :: CInt
+iNFINITE = 0xFFFFFFFF -- urgh
+
+foreign import ccall safe "fdReady"
+ fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
+#endif
+