@@ -5,6 +5,7 @@
55{-# LANGUAGE BangPatterns #-}
66{-# LANGUAGE GeneralizedNewtypeDeriving #-}
77{-# LANGUAGE RecordWildCards #-}
8+{-# LANGUAGE MagicHash #-}
89
910-- | Local nodes
1011--
@@ -60,6 +61,8 @@ import Control.Exception
6061 , Exception
6162 , throwTo
6263 , uninterruptibleMask_
64+ , getMaskingState
65+ , MaskingState(..)
6366 )
6467import qualified Control.Exception as Exception
6568 ( Handler(..)
@@ -206,9 +209,20 @@ import qualified Control.Distributed.Process.Internal.StrictContainerAccessors a
206209 , mapDefault
207210 )
208211import Control.Monad.Catch (try)
212+import GHC.IO (IO(..), unsafeUnmask)
213+import GHC.Base ( maskAsyncExceptions# )
214+
209215import Unsafe.Coerce
210216import Prelude
211217
218+-- Remove these definitions when the fix for
219+-- https://ghc.haskell.org/trac/ghc/ticket/10149
220+-- is included in all supported compilers:
221+block :: IO a -> IO a
222+block (IO io) = IO $ maskAsyncExceptions# io
223+unblock :: IO a -> IO a
224+unblock = unsafeUnmask
225+
212226--------------------------------------------------------------------------------
213227-- Initialization --
214228--------------------------------------------------------------------------------
@@ -346,11 +360,14 @@ runProcess node proc = do
346360
347361-- | Spawn a new process on a local node
348362forkProcess :: LocalNode -> Process () -> IO ProcessId
349−forkProcess node proc =
350− modifyMVarMasked (localState node) startProcess
363+forkProcess node proc = do
364+ ms <- getMaskingState
365+ modifyMVarMasked (localState node) (startProcess ms)
351366 where
352− startProcess :: LocalNodeState -> IO (LocalNodeState, ProcessId)
353− startProcess (LocalNodeValid vst) = do
367+ startProcess :: MaskingState
368+ -> LocalNodeState
369+ -> IO (LocalNodeState, ProcessId)
370+ startProcess ms (LocalNodeValid vst) = do
354371 let lpid = LocalProcessId { lpidCounter = vst ^. localPidCounter
355372 , lpidUnique = vst ^. localPidUnique
356373 }
@@ -372,7 +389,13 @@ forkProcess node proc =
372389 , processThread = tid
373390 , processNode = node
374391 }
375− tid' <- uninterruptibleMask_ $ forkIOWithUnmask $ \unmask -> do
392+ -- Rewrite this code when this is fixed:
393+ -- https://ghc.haskell.org/trac/ghc/ticket/10149
394+ let unmask = case ms of
395+ Unmasked -> unblock
396+ MaskedInterruptible -> block
397+ MaskedUninterruptible -> id
398+ tid' <- uninterruptibleMask_ $ forkIO $ do
376399 reason <- Exception.catches
377400 (unmask $ runLocalProcess lproc proc >> return DiedNormal)
378401 [ (Exception.Handler (\ex@(ProcessExitException from msg) -> do
@@ -418,7 +441,7 @@ forkProcess node proc =
418441 $ vst
419442 , pid
420443 )
421− startProcess LocalNodeClosed =
444+ startProcess _ LocalNodeClosed =
422445 throwIO $ NodeClosedException $ localNodeId node
423446
424447 cleanupProcess :: ProcessId