slave-thread 1.0.2.7 → 1.0.3

raw patch · 4 files changed

+84/−26 lines, 4 filesdep +focus

Dependencies added: focus

Files

• library/SlaveThread.hs +81/−11
• library/SlaveThread/Util/LowLevelForking.hs +1/−9
• slave-thread.cabal +2/−1
• test/Main.hs +0/−5

@@ -34,7 +34,11 @@ module SlaveThread (   fork,+  forkWithUnmask,   forkFinally,+  forkFinallyWithUnmask,+  -- * Notes+  -- $note-unmask ) where @@ -43,6 +47,7 @@ import qualified DeferredFolds.UnfoldlM as UnfoldlM import qualified StmContainers.Multimap as Multimap import qualified Control.Foldl as Foldl+import qualified Focus   -- |@@ -60,6 +65,14 @@   forkFinally $ return ()  -- |+-- Like 'fork', but provides the computation a function that unmasks+-- asynchronous exceptions. See @Note [Unmask]@ at the bottom of this module.+{-# INLINABLE forkWithUnmask #-}+forkWithUnmask :: ((forall x. IO x -> IO x) -> IO a) -> IO ThreadId+forkWithUnmask =+  forkFinallyWithUnmask $ return ()++-- | -- Fork a slave thread with a finalizer action to run a computation on. -- The finalizer gets executed when the thread dies for whatever reason: -- due to being killed or an uncaught exception, or a normal termination.@@ -70,18 +83,26 @@ {-# INLINABLE forkFinally #-} forkFinally :: IO a -> IO b -> IO ThreadId forkFinally finalizer computation =-  uninterruptibleMask_ $ do+  forkFinallyWithUnmask finalizer (\unmask -> unmask computation)++-- |+-- Like 'forkFinally', but provides the computation a function that unmasks+-- asynchronous exceptions. See @Note [Unmask]@ at the bottom of this module.+{-# INLINABLE forkFinallyWithUnmask #-}+forkFinallyWithUnmask :: IO a -> ((forall x. IO x -> IO x) -> IO b) -> IO ThreadId+forkFinallyWithUnmask finalizer computation =+  uninterruptibleMask $ \unmask -> do+     masterThread <- myThreadId-    -- Ensures that the thread gets registered before being unregistered-    registrationGate <- newEmptyMVar-    slaveThread <- forkIOWithUnmaskWithoutHandler $ \ unmask -> do +    slaveThread <- forkIOWithoutHandler $ do+       slaveThread <- myThreadId        -- Execute the main computation:-      computationExceptions <- catch (unmask computation $> empty) (return . pure)+      computationExceptions <- catch (computation unmask $> empty) (return . pure) -      -- Kill the slaves and wait for them to die:      +      -- Kill the slaves and wait for them to die:       slavesDyingExceptions <- let         loop !exceptions =           catch@@ -107,13 +128,16 @@           forM_ @Maybe finalizerExceptions handler        -- Unregister from the global state,-      -- thus informing the master of this thread's death:-      takeMVar registrationGate-      atomically $ Multimap.delete slaveThread masterThread slaveRegistry+      -- thus informing the master of this thread's death.+      -- Whilst doing so, also ensure that the master has already registered this slave.+      atomically $ do+        result <- Multimap.focus Focus.lookupAndDelete slaveThread masterThread slaveRegistry+        case result of+          Just _ -> return ()+          _ -> retry      atomically $ Multimap.insert slaveThread masterThread slaveRegistry-    putMVar registrationGate ()-    +     return slaveThread  killSlaves :: ThreadId -> IO ()@@ -126,3 +150,49 @@   atomically $ do     null <- UnfoldlM.null $ Multimap.unfoldMByKey thread slaveRegistry     unless null retry++-- $note-unmask+--+-- == Masking+--+-- Threads forked by this library, unlike in @base@, /already/ mask asynchronous+-- exceptions internally, for bookkeeping purposes.+--+-- The @*withUnmask@ variants of 'fork' are thus different from the+-- @*withUnmask@ variants found in @base@ and @async@, in that the unmasking+-- function they provide restores the masking state /to that of the calling context/,+-- as opposed to /unmasked/.+--+-- Put another way, the @base@ code that you may have written as:+--+-- @+-- mask (\\unmask -> forkIO (initialize >> unmask computation))+-- @+--+-- using this library would be instead written as:+--+-- @+-- 'forkWithUnmask' (\\unmask -> initialize >> unmask computation)+-- @+--+-- And the @base@ code that you may have written as:+--+-- @+-- mask_ (forkIOWithUnmask (\\unmask -> initialize >> unmask computation))+-- @+--+-- will instead have to /manually/ call the low-level unmasking function called+-- 'GHC.IO.unsafeUnmask', as:+--+-- @+-- mask_ ('forkWithUnmask' (\\_ -> initialize >> unsafeUnmask computation))+-- @+--+-- Note that we used 'forkWithUnmask' (to guarantee @initialize@ is run with+-- asynchronous exceptions masked), but the unmasking function it provided does+-- not guarantee asynchronous exceptions are actually unmasked, so we toss it+-- and use 'GHC.IO.unsafeUnmask' instead.+--+-- This idiom is uncommon, but necessary when you need to fork a thread in+-- library code that is unsure if it's being called with asynchronous exceptions+-- masked (as in the "acquire" phase of a @bracket@ call).

@@ -8,13 +8,5 @@ -- which does not install a default exception handler on the forked thread. {-# INLINE forkIOWithoutHandler #-} forkIOWithoutHandler :: IO () -> IO ThreadId-forkIOWithoutHandler action = +forkIOWithoutHandler action =   IO $ \s -> case (fork# action s) of (# s', tid #) -> (# s', ThreadId tid #)---- |--- A more efficient version of 'forkIOWithUnmask',--- which does not install a default exception handler on the forked thread.-{-# INLINE forkIOWithUnmaskWithoutHandler #-}-forkIOWithUnmaskWithoutHandler :: ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId-forkIOWithUnmaskWithoutHandler action =-  forkIOWithoutHandler (action unsafeUnmask)

@@ -1,5 +1,5 @@ name: slave-thread-version: 1.0.2.7+version: 1.0.3 synopsis: A fundamental solution to ghost threads and silent exceptions description:   Vanilla thread management in Haskell is low level and @@ -60,6 +60,7 @@   build-depends:     base >=4.9 && <5,     deferred-folds >=0.9 && <0.10,+    focus >=1 && <1.1,     foldl >=1 && <2,     stm-containers >=1.1 && <1.2 

@@ -124,11 +124,6 @@         killThread thread         assertEqual "First finalizer is not slave" 0 =<< atomically (readTMVar var)     ,-    testCase "Forked threads don't inherit the masking state" $ do-      var <- newEmptyMVar-      mask_ (S.fork (getMaskingState >>= putMVar var))-      assertEqual "" Unmasked =<< takeMVar var-    ,     testCase "Slave thread finalizer is not interrupted by its own death (#11)" $ do       -- Set up the ref that should be written to by thread 2's finalizer,       -- otherwise there's a bug.