git.iko.soy/distributed-process
on master help sign in
Have spawnLocal inherit the masking state of the caller.
8d406d1Facundo Domínguez
src/Control/Distributed/Process/Node.hs+29−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--
@@ -60,6 +61,8 @@ import Control.Exception
60 , Exception
61 , Exception
61 , throwTo
62 , throwTo
62 , uninterruptibleMask_
63 , uninterruptibleMask_
64+ , getMaskingState
65+ , MaskingState(..)
63 )
66 )
64import qualified Control.Exception as Exception
67import qualified Control.Exception as Exception
65 ( Handler(..)
68 ( Handler(..)
@@ -210,9 +213,20 @@ import qualified Control.Distributed.Process.Internal.StrictContainerAccessors a
210 , mapDefault
213 , mapDefault
211 )
214 )
212import Control.Monad.Catch (try)
215import Control.Monad.Catch (try)
216+import GHC.IO (IO(..), unsafeUnmask)
217+import GHC.Base ( maskAsyncExceptions# )
218+
213import Unsafe.Coerce
219import Unsafe.Coerce
214import Prelude
220import Prelude
215
221
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+
216--------------------------------------------------------------------------------
230--------------------------------------------------------------------------------
217-- Initialization --
231-- Initialization --
218--------------------------------------------------------------------------------
232--------------------------------------------------------------------------------
@@ -352,11 +366,14 @@ runProcess node proc = do
352
366
353-- | Spawn a new process on a local node
367-- | Spawn a new process on a local node
354forkProcess :: LocalNode -> Process () -> IO ProcessId
368forkProcess :: LocalNode -> Process () -> IO ProcessId
355−forkProcess node proc =
369+forkProcess node proc = do
370+ ms <- getMaskingState
356− modifyMVarMasked (localState node) startProcess
371+ modifyMVarMasked (localState node) (startProcess ms)
357 where
372 where
373+ startProcess :: MaskingState
374+ -> LocalNodeState
358− startProcess :: LocalNodeState -> IO (LocalNodeState, ProcessId)
375+ -> IO (LocalNodeState, ProcessId)
359− startProcess (LocalNodeValid vst) = do
376+ startProcess ms (LocalNodeValid vst) = do
360 let lpid = LocalProcessId { lpidCounter = vst ^. localPidCounter
377 let lpid = LocalProcessId { lpidCounter = vst ^. localPidCounter
361 , lpidUnique = vst ^. localPidUnique
378 , lpidUnique = vst ^. localPidUnique
362 }
379 }
@@ -378,7 +395,13 @@ forkProcess node proc =
378 , processThread = tid
395 , processThread = tid
379 , processNode = node
396 , processNode = node
380 }
397 }
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
381− tid' <- uninterruptibleMask_ $ forkIOWithUnmask $ \unmask -> do
404+ tid' <- uninterruptibleMask_ $ forkIO $ do
382 reason <- Exception.catches
405 reason <- Exception.catches
383 (unmask $ runLocalProcess lproc proc >> return DiedNormal)
406 (unmask $ runLocalProcess lproc proc >> return DiedNormal)
384 [ (Exception.Handler (\ex@(ProcessExitException from msg) -> do
407 [ (Exception.Handler (\ex@(ProcessExitException from msg) -> do
@@ -424,7 +447,7 @@ forkProcess node proc =
424 $ vst
447 $ vst
425 , pid
448 , pid
426 )
449 )
427− startProcess LocalNodeClosed =
450+ startProcess _ LocalNodeClosed =
428 throwIO $ NodeClosedException $ localNodeId node
451 throwIO $ NodeClosedException $ localNodeId node
429
452
430 cleanupProcess :: ProcessId
453 cleanupProcess :: ProcessId