[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 00:13:25 UTC 2024



Ben Gamari pushed to branch wip/ghc-internals-move at Glasgow Haskell Compiler / GHC


Commits:
afe4183e by Ben Gamari at 2024-01-25T19:13:13-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,198 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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.IO           ( unsafeUnmask, catchException )
+import GHC.IORef        ( newIORef, readIORef, writeIORef )
+import GHC.Base
+import Foreign.StablePtr
+import Foreign.C.Types
+#endif
+
+
+#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/afe4183e6cdf74581e179a715c236ff69deef8eb

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/afe4183e6cdf74581e179a715c236ff69deef8eb
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/20240125/af26214f/attachment-0001.html>


More information about the ghc-commits mailing list