@@ -5,6 +5,7 @@
55{-# LANGUAGE BangPatterns #-}
66{-# LANGUAGE GeneralizedNewtypeDeriving #-}
77{-# LANGUAGE RecordWildCards #-}
8+{-# LANGUAGE MagicHash #-}
89
910-- | Local nodes
1011--
@@ -65,6 +66,8 @@ import Control.Exception
6566 , Exception
6667 , throwTo
6768 , uninterruptibleMask_
69+ , getMaskingState
70+ , MaskingState(..)
6871 )
6972import qualified Control.Exception as Exception
7073 ( Handler(..)
@@ -224,8 +227,18 @@ import qualified Control.Distributed.Process.Internal.StrictContainerAccessors a
224227 ( mapMaybe
225228 , mapDefault
226229 )
230+import GHC.IO (IO(..), unsafeUnmask)
231+import GHC.Base ( maskAsyncExceptions# )
232+
227233import Unsafe.Coerce
228234
235+-- Remove these when this is fixed:
236+-- https://ghc.haskell.org/trac/ghc/ticket/10149
237+block :: IO a -> IO a
238+block (IO io) = IO $ maskAsyncExceptions# io
239+unblock :: IO a -> IO a
240+unblock = unsafeUnmask
241+
229242--------------------------------------------------------------------------------
230243-- Initialization --
231244--------------------------------------------------------------------------------
@@ -369,11 +382,14 @@ runProcess node proc = do
369382
370383-- | Spawn a new process on a local node
371384forkProcess :: LocalNode -> Process () -> IO ProcessId
372−forkProcess node proc =
373− modifyMVarMasked (localState node) startProcess
385+forkProcess node proc = do
386+ ms <- getMaskingState
387+ modifyMVarMasked (localState node) (startProcess ms)
374388 where
375− startProcess :: LocalNodeState -> IO (LocalNodeState, ProcessId)
376− startProcess (LocalNodeValid vst) = do
389+ startProcess :: MaskingState
390+ -> LocalNodeState
391+ -> IO (LocalNodeState, ProcessId)
392+ startProcess ms (LocalNodeValid vst) = do
377393 let lpid = LocalProcessId { lpidCounter = vst ^. localPidCounter
378394 , lpidUnique = vst ^. localPidUnique
379395 }
@@ -395,7 +411,13 @@ forkProcess node proc =
395411 , processThread = tid
396412 , processNode = node
397413 }
398− tid' <- uninterruptibleMask_ $ forkIOWithUnmask $ \unmask -> do
414+ -- Rewrite this code when this is fixed:
415+ -- https://ghc.haskell.org/trac/ghc/ticket/10149
416+ let unmask = case ms of
417+ Unmasked -> unblock
418+ MaskedInterruptible -> block
419+ MaskedUninterruptible -> id
420+ tid' <- uninterruptibleMask_ $ forkIO $ do
399421 reason <- Exception.catches
400422 (unmask $ runLocalProcess lproc proc >> return DiedNormal)
401423 [ (Exception.Handler (\ex@(ProcessExitException from msg) -> do
@@ -441,7 +463,7 @@ forkProcess node proc =
441463 $ vst
442464 , pid
443465 )
444− startProcess LocalNodeClosed =
466+ startProcess _ LocalNodeClosed =
445467 throwIO $ NodeClosedException $ localNodeId node
446468
447469 cleanupProcess :: ProcessId