[commit: base] windows-iocp: Add forkOSMasked to GHC.Conc.Sync (b107946)

[Joey Adams]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : windows-iocp

http://hackage.haskell.org/trac/ghc/changeset/b107946f3febe57808e1b44dfa7d6621825f9615

>---------------------------------------------------------------

commit b107946f3febe57808e1b44dfa7d6621825f9615
Author: Joey Adams <joeyadams3.14159 at gmail.com>
Date:   Sun Nov 18 01:13:35 2012 -0500

    Add forkOSMasked to GHC.Conc.Sync
    
    Also, make rtsSupportsBoundThreads an unsafe foreign import, and move its
    definition to GHC.Conc.Sync.
    
    This breaks an import cycle, as the new Windows I/O manager will (likely) need
    forkOS.  Importing it from Control.Concurrent produces a cycle: IO manager ->
    Control.Concurrent -> GHC.Conc.IO -> IO manager.  forkOSMasked is defined in
    GHC.Conc.Sync, which has much fewer transitive dependencies.
    
    forkOSMasked is intended to be internal.  That's why it's exported by
    GHC.Conc.Sync but not by Control.Concurrent.

>---------------------------------------------------------------

 Control/Concurrent.hs |   40 +++++++++-------------------------------
 GHC/Conc.lhs          |    2 ++
 GHC/Conc/Sync.lhs     |   35 +++++++++++++++++++++++++++++++++++
 GHC/ConsoleHandler.hs |    2 +-
 GHC/IO/FD.hs          |    2 +-
 5 files changed, 48 insertions(+), 33 deletions(-)

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index 95ad957..58ab32e 100644
--- a/Control/Concurrent.hs
+++ b/Control/Concurrent.hs
@@ -263,12 +263,6 @@ 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'
@@ -302,35 +296,19 @@ 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 = 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
+forkOS action = do
+    b <- Exception.getMaskingState
+    forkOSMasked $
+        -- async exceptions are masked in the child if they are masked
+        -- in the parent, as for forkIO (see #1048).
+        case b of
+            Unmasked -> unsafeUnmask action
+            MaskedInterruptible -> action
+            MaskedUninterruptible -> uninterruptibleMask_ action
 
 -- | 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
diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 914db3f..65d6492 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -37,6 +37,8 @@ module GHC.Conc
         , forkOnIO
         , forkOnIOUnmasked
         , forkOnWithUnmask
+        , rtsSupportsBoundThreads
+        , forkOSMasked
         , numCapabilities
         , getNumCapabilities
         , setNumCapabilities
diff --git a/GHC/Conc/Sync.lhs b/GHC/Conc/Sync.lhs
index ec266e9..dd9b262 100644
--- a/GHC/Conc/Sync.lhs
+++ b/GHC/Conc/Sync.lhs
@@ -47,6 +47,8 @@ module GHC.Conc.Sync
         , forkOnIO    -- DEPRECATED
         , forkOnIOUnmasked
         , forkOnWithUnmask
+        , rtsSupportsBoundThreads
+        , forkOSMasked
         , numCapabilities
         , getNumCapabilities
         , setNumCapabilities
@@ -272,6 +274,39 @@ forkOnIOUnmasked cpu io = forkOn cpu (unsafeUnmask io)
 forkOnWithUnmask :: Int -> ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
 forkOnWithUnmask cpu io = forkOn cpu (io unsafeUnmask)
 
+-- | '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 'Control.Concurrent.forkOS', but start the thread in
+-- 'Control.Exception.MaskedInterruptible', rather than inheriting the masking
+-- state from the caller.
+forkOSMasked :: IO () -> IO ThreadId
+
+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)"
+
+forkOSMasked action
+    | rtsSupportsBoundThreads = do
+        mv <- newEmptyMVar
+        entry <- newStablePtr (myThreadId >>= putMVar mv >> action_plus)
+        err <- forkOS_createThread entry
+            -- forkOS_createThread creates a thread with exceptions
+            -- masked by default.
+        when (err /= 0) $ fail "Cannot create OS thread."
+        tid <- takeMVar mv
+        freeStablePtr entry
+        return tid
+    | otherwise = failNonThreaded
+  where
+    action_plus = catchException action childHandler
+
 -- | the value passed to the @+RTS -N@ flag.  This is the number of
 -- Haskell threads that can run truly simultaneously at any given
 -- time, and is typically set to the number of physical processor cores on
diff --git a/GHC/ConsoleHandler.hs b/GHC/ConsoleHandler.hs
index 95810d6..98c55d0 100644
--- a/GHC/ConsoleHandler.hs
+++ b/GHC/ConsoleHandler.hs
@@ -133,7 +133,7 @@ installHandler handler
 
    no_handler = error "win32ConsoleHandler"
 
-foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
+foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
 
 foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent" 
   rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs
index 0f37a81..536c19c 100644
--- a/GHC/IO/FD.hs
+++ b/GHC/IO/FD.hs
@@ -638,7 +638,7 @@ foreign import WINDOWS_CCONV safe "send"
 
 #endif
 
-foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
+foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
 
 -- -----------------------------------------------------------------------------
 -- utils