@@ -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(..)
@@ -210,9 +213,20 @@ import qualified Control.Distributed.Process.Internal.StrictContainerAccessors a
210213 , mapDefault
211214 )
212215import Control.Monad.Catch (try)
216+import GHC.IO (IO(..), unsafeUnmask)
217+import GHC.Base ( maskAsyncExceptions# )
218+
213219import Unsafe.Coerce
214220import Prelude
215221
222+-- Remove these definitions when the fix for
223+-- https://ghc.haskell.org/trac/ghc/ticket/10149
224+-- is included in all supported compilers:
225+block :: IO a -> IO a
226+block (IO io) = IO $ maskAsyncExceptions# io
227+unblock :: IO a -> IO a
228+unblock = unsafeUnmask
229+
216230--------------------------------------------------------------------------------
217231-- Initialization --
218232--------------------------------------------------------------------------------
@@ -352,11 +366,14 @@ runProcess node proc = do
352366
353367-- | Spawn a new process on a local node
354368forkProcess :: LocalNode -> Process () -> IO ProcessId
355−forkProcess node proc =
356− modifyMVarMasked (localState node) startProcess
369+forkProcess node proc = do
370+ ms <- getMaskingState
371+ modifyMVarMasked (localState node) (startProcess ms)
357372 where
358− startProcess :: LocalNodeState -> IO (LocalNodeState, ProcessId)
359− startProcess (LocalNodeValid vst) = do
373+ startProcess :: MaskingState
374+ -> LocalNodeState
375+ -> IO (LocalNodeState, ProcessId)
376+ startProcess ms (LocalNodeValid vst) = do
360377 let lpid = LocalProcessId { lpidCounter = vst ^. localPidCounter
361378 , lpidUnique = vst ^. localPidUnique
362379 }
@@ -378,7 +395,13 @@ forkProcess node proc =
378395 , processThread = tid
379396 , processNode = node
380397 }
381− tid' <- uninterruptibleMask_ $ forkIOWithUnmask $ \unmask -> do
398+ -- Rewrite this code when this is fixed:
399+ -- https://ghc.haskell.org/trac/ghc/ticket/10149
400+ let unmask = case ms of
401+ Unmasked -> unblock
402+ MaskedInterruptible -> block
403+ MaskedUninterruptible -> id
404+ tid' <- uninterruptibleMask_ $ forkIO $ do
382405 reason <- Exception.catches
383406 (unmask $ runLocalProcess lproc proc >> return DiedNormal)
384407 [ (Exception.Handler (\ex@(ProcessExitException from msg) -> do
@@ -424,7 +447,7 @@ forkProcess node proc =
424447 $ vst
425448 , pid
426449 )
427− startProcess LocalNodeClosed =
450+ startProcess _ LocalNodeClosed =
428451 throwIO $ NodeClosedException $ localNodeId node
429452
430453 cleanupProcess :: ProcessId