[Git][ghc/ghc][wip/ghc-internals-move] Move forkOS et al to GHC.Conc.Bound
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri Jan 26 15:24:25 UTC 2024
Ben Gamari pushed to branch wip/ghc-internals-move at Glasgow Haskell Compiler / GHC
Commits:
5cda25ef by Ben Gamari at 2024-01-26T10:24:17-05:00
Move forkOS et al to GHC.Conc.Bound
- - - - -
4 changed files:
- libraries/base/src/Control/Concurrent.hs
- libraries/ghc-internal/ghc-internal.cabal
- + libraries/ghc-internal/src/GHC/Conc/Bound.hs
- libraries/ghc-internal/src/GHC/Event/Windows.hsc
Changes:
=====================================
libraries/base/src/Control/Concurrent.hs
=====================================
@@ -105,24 +105,12 @@ module Control.Concurrent (
) where
--- JavaScript platform doesn't support bound threads
-#if !defined(javascript_HOST_ARCH)
-#define SUPPORT_BOUND_THREADS
-#endif
-
import Control.Exception.Base as Exception
+import GHC.Conc.Bound
import GHC.Conc hiding (threadWaitRead, threadWaitWrite,
threadWaitReadSTM, threadWaitWriteSTM)
-#if defined(SUPPORT_BOUND_THREADS)
-import GHC.IO ( unsafeUnmask, catchException )
-import GHC.IORef ( newIORef, readIORef, writeIORef )
-import GHC.Base
-import Foreign.StablePtr
-import Foreign.C.Types
-#endif
-
import System.Posix.Types ( Fd )
#if defined(mingw32_HOST_OS)
@@ -258,169 +246,6 @@ waiting for the results in the main thread.
-}
-#if !defined(SUPPORT_BOUND_THREADS)
-forkOS :: IO () -> IO ThreadId
-forkOS _ = error "forkOS not supported on this architecture"
-
-forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
-forkOSWithUnmask _ = error "forkOS not supported on this architecture"
-
-isCurrentThreadBound :: IO Bool
-isCurrentThreadBound = pure False
-
-runInBoundThread :: IO a -> IO a
-runInBoundThread action = action
-
-runInUnboundThread :: IO a -> IO a
-runInUnboundThread action = action
-
-rtsSupportsBoundThreads :: Bool
-rtsSupportsBoundThreads = False
-#else
-
-
--- | '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 '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 at .
--}
-
-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.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 = 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
-
--- | Like 'forkIOWithUnmask', but the child thread is a bound thread,
--- as with 'forkOS'.
-forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
-forkOSWithUnmask io = forkOS (io unsafeUnmask)
-
--- | 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#, isTrue# (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
- bracket (newStablePtr action_plus)
- freeStablePtr
- (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref) >>=
- unsafeResult
- | 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'.
- at 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 its main thread to be bound and makes /heavy/ use of concurrency
-(e.g. a web server), might want to wrap its @main@ action in
- at 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
- mask $ \restore -> do
- tid <- forkIO $ Exception.try (restore action) >>= putMVar mv
- let wait = takeMVar mv `catchException` \(e :: SomeException) ->
- Exception.throwTo tid e >> wait
- wait >>= unsafeResult
- else action
-
-unsafeResult :: Either SomeException a -> IO a
-unsafeResult = either Exception.throwIO return
-
-#endif
-
-- ---------------------------------------------------------------------------
-- threadWaitRead/threadWaitWrite
=====================================
libraries/ghc-internal/ghc-internal.cabal
=====================================
@@ -176,6 +176,7 @@ Library
GHC.Char
GHC.Clock
GHC.Conc
+ GHC.Conc.Bound
GHC.Conc.IO
GHC.Conc.Signal
GHC.Conc.Sync
=====================================
libraries/ghc-internal/src/GHC/Conc/Bound.hs
=====================================
@@ -0,0 +1,216 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE Unsafe #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Conc.Bound
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries at haskell.org
+-- Stability : stable
+-- Portability : non-portable (concurrency)
+--
+-- Bound thread support.
+--
+-----------------------------------------------------------------------------
+
+module GHC.Conc.Bound
+ ( forkOS
+ , forkOSWithUnmask
+ , isCurrentThreadBound
+ , runInBoundThread
+ , runInUnboundThread
+ , rtsSupportsBoundThreads
+ ) where
+
+-- JavaScript platform doesn't support bound threads
+#if !defined(javascript_HOST_ARCH)
+#define SUPPORT_BOUND_THREADS
+#endif
+
+#if defined(SUPPORT_BOUND_THREADS)
+import GHC.Base
+import Foreign.StablePtr
+import Foreign.C.Types
+#endif
+
+import Control.Monad.Fail
+
+import Data.Either
+import qualified Control.Exception.Base as Exception
+import GHC.Conc.Sync
+import GHC.IO
+import GHC.Exception
+import GHC.IORef
+import GHC.MVar
+
+
+#if !defined(SUPPORT_BOUND_THREADS)
+forkOS :: IO () -> IO ThreadId
+forkOS _ = error "forkOS not supported on this architecture"
+
+forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
+forkOSWithUnmask _ = error "forkOS not supported on this architecture"
+
+isCurrentThreadBound :: IO Bool
+isCurrentThreadBound = pure False
+
+runInBoundThread :: IO a -> IO a
+runInBoundThread action = action
+
+runInUnboundThread :: IO a -> IO a
+runInUnboundThread action = action
+
+rtsSupportsBoundThreads :: Bool
+rtsSupportsBoundThreads = False
+#else
+
+-- | '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 '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 at .
+-}
+
+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.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 = 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
+
+-- | Like 'forkIOWithUnmask', but the child thread is a bound thread,
+-- as with 'forkOS'.
+forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
+forkOSWithUnmask io = forkOS (io unsafeUnmask)
+
+-- | 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#, isTrue# (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
+ bracket (newStablePtr action_plus)
+ freeStablePtr
+ (\cEntry -> forkOS_entry_reimported cEntry >> readIORef ref) >>=
+ unsafeResult
+ | 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'.
+ at 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 its main thread to be bound and makes /heavy/ use of concurrency
+(e.g. a web server), might want to wrap its @main@ action in
+ at 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
+ mask $ \restore -> do
+ tid <- forkIO $ Exception.try (restore action) >>= putMVar mv
+ let wait = takeMVar mv `catchException` \(e :: SomeException) ->
+ Exception.throwTo tid e >> wait
+ wait >>= unsafeResult
+ else action
+
+unsafeResult :: Either SomeException a -> IO a
+unsafeResult = either Exception.throwIO return
+
+#endif
=====================================
libraries/ghc-internal/src/GHC/Event/Windows.hsc
=====================================
@@ -108,6 +108,7 @@ import GHC.OldList (deleteBy)
import Foreign
import qualified GHC.Event.Array as A
import GHC.Base
+import GHC.Conc.Bound
import GHC.Conc.Sync
import GHC.IO
import GHC.IOPort
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5cda25ef2fbedd24c2229b0de34c06fbf7a87f51
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5cda25ef2fbedd24c2229b0de34c06fbf7a87f51
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240126/166f5ba8/attachment-0001.html>
More information about the ghc-commits
mailing list