[tor-commits] [tordnsel/master] Control.Concurrent: block/unblock -> mask/restore

[arlo at torproject.org]

commit 848228a5f1f043e5c10e55a0b9715e9c0d452535
Author: David Kaloper <david at numm.org>
Date:   Wed Aug 28 00:05:19 2013 +0200

    Control.Concurrent: block/unblock -> mask/restore
---
 src/TorDNSEL/Control/Concurrent/Future.hs         |  4 ++--
 src/TorDNSEL/Control/Concurrent/Link/Internals.hs | 18 +++++++++++-------
 2 files changed, 13 insertions(+), 9 deletions(-)

diff --git a/src/TorDNSEL/Control/Concurrent/Future.hs b/src/TorDNSEL/Control/Concurrent/Future.hs
index 4b5c6ac..8256477 100644
--- a/src/TorDNSEL/Control/Concurrent/Future.hs
+++ b/src/TorDNSEL/Control/Concurrent/Future.hs
@@ -34,8 +34,8 @@ spawn :: IO a -> IO (Future a)
 spawn io = do
   mv <- newEmptyMVar
   callingThread <- myThreadId
-  forkLinkIO . E.block $ do
-    r <- either (Left . extractReason) (Right . id) `fmap` E.try (E.unblock io)
+  forkLinkIO . E.mask $ \restore -> do
+    r <- either (Left . extractReason) (Right . id) `fmap` E.try (restore io)
     putMVar mv r
     unlinkThread callingThread
     either exit (const $ return ()) r
diff --git a/src/TorDNSEL/Control/Concurrent/Link/Internals.hs b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs
index 7b614b9..5c3f8b2 100644
--- a/src/TorDNSEL/Control/Concurrent/Link/Internals.hs
+++ b/src/TorDNSEL/Control/Concurrent/Link/Internals.hs
@@ -32,6 +32,7 @@ import Control.Concurrent.MVar
 import GHC.Conc (setUncaughtExceptionHandler)
 import System.Exit (ExitCode)
 import Control.Monad (unless)
+import Data.Functor
 import qualified Data.Foldable as F
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -142,7 +143,7 @@ defaultSignal dst src e          = E.throwTo dst $ ExitSignal src e
 withLinksDo :: IO a -> IO ()
 withLinksDo io = E.mask $ \restore -> do
   setUncaughtExceptionHandler . const . return $ ()
-  main <- C.myThreadId
+  main   <- C.myThreadId
   mainId <- Tid `fmap` newUnique
   let initialState = ThreadState
         { ident     = mainId
@@ -158,7 +159,7 @@ withLinksDo io = E.mask $ \restore -> do
          , state = M.insert main initialState (state tm) }
   -- Don't bother propagating signals from the main thread
   -- since it's about to exit.
-  (restore io >> return ()) `E.catch` \(e :: E.SomeException) ->
+  (() <$ restore io) `E.catch` \(e :: E.SomeException) ->
     case extractReason e of
       NormalExit -> return ()
       AbnormalExit (E.fromException -> Just e') ->
@@ -178,8 +179,8 @@ forkLinkIO :: IO a -> IO ThreadId
 forkLinkIO = forkLinkIO' True
 
 forkLinkIO' :: Bool -> IO a -> IO ThreadId
-forkLinkIO' shouldLink io = E.block $ do
-  parent <- C.myThreadId
+forkLinkIO' shouldLink io = E.mask $ \restore -> do
+  parent  <- C.myThreadId
   childId <- Tid `fmap` newUnique
   modifyMVar_ threadMap $ \tm -> do
 #ifdef DEBUG
@@ -187,7 +188,9 @@ forkLinkIO' shouldLink io = E.block $ do
 #endif
     child <- forkHandler $ do
       child <- C.myThreadId
-      e <- either extractReason (const NormalExit) `fmap` E.try (E.unblock io)
+      e     <- either (extractReason :: E.SomeException -> ExitReason)
+                      (const NormalExit)
+                `fmap` E.try (restore io)
       -- modifyMVar is interruptible (a misfeature in this case), so an async
       -- exception could be delivered here. Forking an anonymous thread should
       -- avoid this race since nobody can throwTo it.
@@ -234,9 +237,10 @@ forkLinkIO' shouldLink io = E.block $ do
   withMVar threadMap assertThreadMap
 #endif
   return childId
+
   where
-    forkHandler = C.forkIO . ignore . (>> return ()) . E.block
-    ignore      = E.handle $ \(e :: E.SomeException) -> return ()
+    forkHandler io = E.mask_ . C.forkIO $
+      (() <$ io) `E.catch` \(e :: E.SomeException) -> return ()
 
 -- | Establish a bidirectional link between the calling thread and a given
 -- thread. If either thread terminates, an exit signal will be sent to the other