git.iko.soy/distributed-process
on master help sign in
Have spawnLocal inherit the masking state of the caller.
02b1798Facundo Domínguez
src/Control/Distributed/Process/Node.hs+28−6
compare with master
unifiedsplit
@@ -5,6 +5,7 @@
5{-# LANGUAGE BangPatterns #-}
5{-# LANGUAGE BangPatterns #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE RecordWildCards #-}
8+{-# LANGUAGE MagicHash #-}
8
9
9-- | Local nodes
10-- | Local nodes
10--
11--
@@ -65,6 +66,8 @@ import Control.Exception
65 , Exception
66 , Exception
66 , throwTo
67 , throwTo
67 , uninterruptibleMask_
68 , uninterruptibleMask_
69+ , getMaskingState
70+ , MaskingState(..)
68 )
71 )
69import qualified Control.Exception as Exception
72import qualified Control.Exception as Exception
70 ( Handler(..)
73 ( Handler(..)
@@ -224,8 +227,18 @@ import qualified Control.Distributed.Process.Internal.StrictContainerAccessors a
224 ( mapMaybe
227 ( mapMaybe
225 , mapDefault
228 , mapDefault
226 )
229 )
230+import GHC.IO (IO(..), unsafeUnmask)
231+import GHC.Base ( maskAsyncExceptions# )
232+
227import Unsafe.Coerce
233import Unsafe.Coerce
228
234
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+
229--------------------------------------------------------------------------------
242--------------------------------------------------------------------------------
230-- Initialization --
243-- Initialization --
231--------------------------------------------------------------------------------
244--------------------------------------------------------------------------------
@@ -369,11 +382,14 @@ runProcess node proc = do
369
382
370-- | Spawn a new process on a local node
383-- | Spawn a new process on a local node
371forkProcess :: LocalNode -> Process () -> IO ProcessId
384forkProcess :: LocalNode -> Process () -> IO ProcessId
372−forkProcess node proc =
385+forkProcess node proc = do
386+ ms <- getMaskingState
373− modifyMVarMasked (localState node) startProcess
387+ modifyMVarMasked (localState node) (startProcess ms)
374 where
388 where
389+ startProcess :: MaskingState
390+ -> LocalNodeState
375− startProcess :: LocalNodeState -> IO (LocalNodeState, ProcessId)
391+ -> IO (LocalNodeState, ProcessId)
376− startProcess (LocalNodeValid vst) = do
392+ startProcess ms (LocalNodeValid vst) = do
377 let lpid = LocalProcessId { lpidCounter = vst ^. localPidCounter
393 let lpid = LocalProcessId { lpidCounter = vst ^. localPidCounter
378 , lpidUnique = vst ^. localPidUnique
394 , lpidUnique = vst ^. localPidUnique
379 }
395 }
@@ -395,7 +411,13 @@ forkProcess node proc =
395 , processThread = tid
411 , processThread = tid
396 , processNode = node
412 , processNode = node
397 }
413 }
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
398− tid' <- uninterruptibleMask_ $ forkIOWithUnmask $ \unmask -> do
420+ tid' <- uninterruptibleMask_ $ forkIO $ do
399 reason <- Exception.catches
421 reason <- Exception.catches
400 (unmask $ runLocalProcess lproc proc >> return DiedNormal)
422 (unmask $ runLocalProcess lproc proc >> return DiedNormal)
401 [ (Exception.Handler (\ex@(ProcessExitException from msg) -> do
423 [ (Exception.Handler (\ex@(ProcessExitException from msg) -> do
@@ -441,7 +463,7 @@ forkProcess node proc =
441 $ vst
463 $ vst
442 , pid
464 , pid
443 )
465 )
444− startProcess LocalNodeClosed =
466+ startProcess _ LocalNodeClosed =
445 throwIO $ NodeClosedException $ localNodeId node
467 throwIO $ NodeClosedException $ localNodeId node
446
468
447 cleanupProcess :: ProcessId
469 cleanupProcess :: ProcessId