slave-thread 0.1.1 → 0.1.2

raw patch · 3 files changed

+55/−46 lines, 3 files

Files

• library/SlaveThread.hs +24/−19
• slave-thread.cabal +1/−1
• tests/Main.hs +30/−26

@@ -41,6 +41,8 @@ import BasePrelude hiding (forkFinally) import Control.Monad.Trans.Reader import Control.Monad.Morph+import GHC.IO (IO(IO))+import GHC.Exts (Int(I#), fork#, forkOn#) import qualified STMContainers.Multimap as Multimap import qualified PartialHandler import qualified ListT@@ -71,32 +73,29 @@ {-# INLINABLE forkFinally #-} forkFinally :: IO a -> IO b -> IO ThreadId forkFinally finalizer computation =-  do+  mask $ \unmask -> do     masterThread <- myThreadId-    -- Ensures that the thread gets registered before this function returns.-    semaphore <- newEmptyMVar+    -- Ensures that the thread gets registered before being unregistered+    registrationPass <- newEmptyMVar     slaveThread <--      mask $ \restore -> forkIO $ do+      forkIOWithoutHandler $ do         slaveThread <- myThreadId-        atomically $ Multimap.insert slaveThread masterThread slaves-        putMVar semaphore ()-        r <- try $ restore computation+        catch (void $ unmask computation) $+          PartialHandler.totalizeRethrowingTo_ masterThread $ +            PartialHandler.onThreadKilled (return ())         -- Context management:         killSlaves slaveThread         waitForSlavesToDie slaveThread-        -- Finalization and rethrowing of exceptions into the master thread:-        forM_ (left r) $ -          PartialHandler.totalizeRethrowingTo_ masterThread $ -            PartialHandler.onThreadKilled (return ())-        try finalizer >>= \r ->-          forM_ (left r) $ PartialHandler.totalizeRethrowingTo_ masterThread $ mempty+        -- Finalization:+        catch (void finalizer) $+          PartialHandler.totalizeRethrowingTo_ masterThread $ mempty         -- Unregister from the global state,         -- thus informing the master of this thread's death.+        takeMVar registrationPass         atomically $ Multimap.delete slaveThread masterThread slaves-    takeMVar semaphore+    atomically $ Multimap.insert slaveThread masterThread slaves+    putMVar registrationPass ()     return slaveThread-  where-    left = either Just (const Nothing)  killSlaves :: ThreadId -> IO () killSlaves thread =@@ -106,6 +105,12 @@ waitForSlavesToDie thread =   atomically $ do     null <- ListT.null $ Multimap.streamByKey thread slaves-    if null-      then return ()-      else retry+    when (not null) retry++-- |+-- 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 #)

@@ -1,7 +1,7 @@ name:   slave-thread version:-  0.1.1+  0.1.2 synopsis:   A solution to ghost threads and silent exceptions description:

@@ -13,9 +13,9 @@   test_forkedThreadsRunFine = -  replicateM 100 $ do-    var <- newIORef 0-    let increment = modifyIORef var (+1)+  replicateM 100000 $ do+    var <- newMVar 0+    let increment = modifyMVar_ var (return . succ)     semaphore <- SSem.new 0     S.fork $ do       increment@@ -29,58 +29,62 @@       SSem.wait semaphore'       SSem.signal semaphore     SSem.wait semaphore-    assertEqual 3 =<< readIORef var+    assertEqual 3 =<< readMVar var  test_killingAThreadKillsDeepSlaves = -  replicateM 100 $ do-    var <- newIORef 0-    let increment = modifyIORef var (+1)+  replicateM 100000 $ do+    var <- newMVar 0     semaphore <- SSem.new 0     thread <-        S.forkFinally (SSem.signal semaphore) $ do-        w <- forkWait $ do-          w <- forkWait $ do-            threadDelay $ 20*10^3-            increment-          w-        w+        join $ forkWait $ do+          join $ forkWait $ do+            w <- forkWait $ do+              threadDelay $ 10^6+              modifyMVar_ var (return . succ)+            threadDelay $ 10^6+            modifyMVar_ var (return . succ)+            w     killThread thread     SSem.wait semaphore-    assertEqual 0 =<< readIORef var+    assertEqual 0 =<< readMVar var  test_dyingNormallyKillsSlaves = -  replicateM 100 $ do+  replicateM 100000 $ do     var <- newIORef 0     let increment = modifyIORef var (+1)     semaphore <- SSem.new 0     S.forkFinally (SSem.signal semaphore) $ do       S.fork $ do-        threadDelay $ 10^4+        threadDelay $ 10^6         increment       S.fork $ do-        threadDelay $ 10^4+        threadDelay $ 10^6         increment     SSem.wait semaphore     assertEqual 0 =<< readIORef var  test_finalizationOrder = -  replicateM 1000 $ do-    var <- newIORef 0+  replicateM 100000 $ do+    var <- newMVar []     semaphore <- SSem.new 0-    S.forkFinally (modifyIORef var (*2) >> SSem.signal semaphore) $ do-      S.forkFinally (modifyIORef var (+1)) $ return ()-      S.forkFinally (modifyIORef var (+1)) $ return ()+    S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (1:)) >> SSem.signal semaphore)) $ do+      semaphore' <- SSem.new 0+      S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (2:)) >> SSem.signal semaphore')) $ do+        S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (3:)))) $ return ()+        S.forkFinally (uninterruptibleMask_ (modifyMVar_ var (return . (3:)))) $ return ()+      SSem.wait semaphore'     SSem.wait semaphore-    assertEqual 4 =<< readIORef var+    assertEqual [1,2,3,3] =<< readMVar var  test_exceptionsDontGetLost = -  replicateM 100 $ do+  replicateM 100000 $ do     assertThrowsSomeIO $ do       S.fork $ do         S.fork $ do           error "!"-        threadDelay $ 10^4-      threadDelay $ 10^4+        threadDelay $ 10^6+      threadDelay $ 10^6  forkWait :: IO a -> IO (IO ()) forkWait io =