packages feed

slave-thread 1.0.2.6 → 1.0.2.7

raw patch · 5 files changed

+175/−49 lines, 5 filesdep −transformersPVP ok

version bump matches the API change (PVP)

Dependencies removed: transformers

API changes (from Hackage documentation)

Files

library/SlaveThread.hs view
@@ -38,18 +38,8 @@ ) where -import Prelude-import Data.Foldable-import Data.Traversable-import Control.Applicative-import Control.Concurrent hiding (forkFinally)-import Control.Exception-import Control.Monad-import Control.Monad.Trans.Reader-import GHC.Conc-import GHC.Exts (Int(I#), fork#, forkOn#)-import GHC.IO (IO(IO), unsafeUnmask)-import System.IO.Unsafe+import SlaveThread.Prelude+import SlaveThread.Util.LowLevelForking import qualified DeferredFolds.UnfoldlM as UnfoldlM import qualified StmContainers.Multimap as Multimap import qualified Control.Foldl as Foldl@@ -57,9 +47,9 @@  -- | -- A global registry of all slave threads by their masters.-{-# NOINLINE slaves #-}-slaves :: Multimap.Multimap ThreadId ThreadId-slaves =+{-# NOINLINE slaveRegistry #-}+slaveRegistry :: Multimap.Multimap ThreadId ThreadId+slaveRegistry =   unsafePerformIO Multimap.newIO  -- |@@ -89,52 +79,50 @@       slaveThread <- myThreadId        -- Execute the main computation:-      catch (unmask (void computation)) $ \ e ->-        case fromException e of-          Just ThreadKilled -> return ()-          _ -> throwTo masterThread e+      computationExceptions <- catch (unmask computation $> empty) (return . pure)        -- Kill the slaves and wait for them to die:      -      catch-        (unmask $ do-          killSlaves slaveThread-          waitForSlavesToDie slaveThread)-        (\ e -> case fromException e of-          Just ThreadKilled -> return ()-          _ -> throwTo masterThread e)+      slavesDyingExceptions <- let+        loop !exceptions =+          catch+            (unmask $ do+              killSlaves slaveThread+              waitForSlavesToDie slaveThread+              return exceptions)+            (\ !exception -> loop (exception : exceptions))+          in loop []        -- Finalize:-      finalizerResult <- try @SomeException (void finalizer)+      finalizerExceptions <- catch (finalizer $> empty) (return . pure) +      -- Rethrow the exceptions:+      let+        handler e = do+          case fromException e of+            Just ThreadKilled -> return ()+            _ -> throwTo masterThread e+        in do+          forM_ @Maybe computationExceptions handler+          forM_ slavesDyingExceptions handler+          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 slaves--      -- -      case finalizerResult of-        Left e -> throwTo masterThread e-        _ -> return ()+      atomically $ Multimap.delete slaveThread masterThread slaveRegistry -    atomically $ Multimap.insert slaveThread masterThread slaves+    atomically $ Multimap.insert slaveThread masterThread slaveRegistry     putMVar registrationGate ()+         return slaveThread  killSlaves :: ThreadId -> IO () killSlaves thread = do-  threads <- atomically (UnfoldlM.foldM (Foldl.generalize Foldl.revList) (Multimap.unfoldMByKey thread slaves))+  threads <- atomically (UnfoldlM.foldM (Foldl.generalize Foldl.revList) (Multimap.unfoldMByKey thread slaveRegistry))   traverse_ killThread threads  waitForSlavesToDie :: ThreadId -> IO () waitForSlavesToDie thread =   atomically $ do-    null <- UnfoldlM.null $ Multimap.unfoldMByKey thread slaves+    null <- UnfoldlM.null $ Multimap.unfoldMByKey thread slaveRegistry     unless null retry---- |--- 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 =-  IO $ \s -> case (fork# (action unsafeUnmask)  s) of (# s', tid #) -> (# s', ThreadId tid #)
+ library/SlaveThread/Prelude.hs view
@@ -0,0 +1,72 @@+module SlaveThread.Prelude+(+  module Exports,+)+where++-- base+-------------------------+import Control.Applicative as Exports+import Control.Arrow as Exports+import Control.Category as Exports+import Control.Concurrent as Exports hiding (forkFinally)+import Control.Exception as Exports+import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.IO.Class as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.ST as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports hiding (toList)+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports+import Data.Functor.Identity as Exports+import Data.Int as Exports+import Data.IORef as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (Last(..), First(..), (<>))+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.Semigroup as Exports+import Data.STRef as Exports+import Data.String as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports hiding (sizeOf, alignment)+import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)+import GHC.Exts as Exports (lazy, inline, sortWith, groupWith, IsList(..), Int(I#), fork#, forkOn#)+import GHC.Generics as Exports (Generic)+import GHC.IO as Exports (IO(IO), unsafeUnmask)+import GHC.IO.Exception as Exports+import Numeric as Exports+import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (printf, hPrintf)+import Text.Read as Exports (Read(..), readMaybe, readEither)+import Unsafe.Coerce as Exports
+ library/SlaveThread/Util/LowLevelForking.hs view
@@ -0,0 +1,20 @@+module SlaveThread.Util.LowLevelForking where++import SlaveThread.Prelude+++-- |+-- A more efficient version of 'forkIO',+-- which does not install a default exception handler on the forked thread.+{-# INLINE forkIOWithoutHandler #-}+forkIOWithoutHandler :: IO () -> IO ThreadId+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)
slave-thread.cabal view
@@ -1,5 +1,5 @@ name: slave-thread-version: 1.0.2.6+version: 1.0.2.7 synopsis: A fundamental solution to ghost threads and silent exceptions description:   Vanilla thread management in Haskell is low level and @@ -54,12 +54,14 @@   default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples   default-language: Haskell2010   exposed-modules: SlaveThread+  other-modules:+    SlaveThread.Prelude+    SlaveThread.Util.LowLevelForking   build-depends:     base >=4.9 && <5,     deferred-folds >=0.9 && <0.10,     foldl >=1 && <2,-    stm-containers >=1.1 && <1.2,-    transformers >=0.5 && <0.6+    stm-containers >=1.1 && <1.2  test-suite test   type: exitcode-stdio-1.0
test/Main.hs view
@@ -130,17 +130,61 @@       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.       ref <- newIORef True++      -- Let the main thread know when it should check the above IORef.       done <- newEmptyMVar++      -- The gist of the test below: assert that, when a thread fails (here, the+      -- inner thread), its finalizer is not interrupted by a ThreadKilled+      -- thrown by the parent, which was originally triggered by its own death.+       S.forkFinally (putMVar done ()) $ do++        -- Let thread 2 know when it should die, with thread 1's exception+        -- handler in place.         ready <- newEmptyMVar-        S.forkFinally (catch @SomeException (threadDelay (10^6)) (\_ -> writeIORef ref False)) $ do++        S.forkFinally+          (catch @SomeException (threadDelay (10^5)) (\_ -> writeIORef ref False)) $ do++          -- Wait until thread 1 is ready for us to die.           takeMVar ready++          -- Die.           throwIO (userError "")+         catch @SomeException-          (putMVar ready () >> threadDelay (10^6)) (\_ -> return ())+          ( -- Tell thread 2 we're ready for it to die+            putMVar ready () >>++            -- Sleep until thread 2 kills us.+            threadDelay (10^5*2)+          )+          -- Ignore thread 2's exception, so we don't propagate it up to the+          -- main thread.+          (\ _ -> return ())+       takeMVar done       assertBool "Slave thread finalizer interrupted" =<< readIORef ref+    ,+    testCase "Master kills all slaves, even if it is thrown an exception during (#13)" $ do+      survived <- newEmptyTMVarIO+      ready <- newEmptyMVar+      done <- newEmptyMVar+      thread <-+        S.fork $ do+          S.forkFinally (atomically (tryPutTMVar survived True)) $ do+            uninterruptibleMask_ (putMVar ready () >> threadDelay (10^6))+            atomically (putTMVar survived False)+          takeMVar ready+          putMVar done ()+      takeMVar done+      threadDelay $ 10^5 -- be reasonably sure it's trying to kill its child+      killThread thread+      assertBool "Slave thread not killed by master" =<< atomically (takeTMVar survived)   ]  forkWait :: IO a -> IO (IO ())