b1bc105 · distributed-process

git.iko.soy/distributed-process

Improve exception handling in callLocal.

callLocal had the following flaws: 1. It could leak the worker process if the parent process was interrupted but not killed. Linking the worker to the parent wouldn't help. 2. If the parent was interrupted, `callLocal` would return the control before the worker is terminated. This would make slightly harder to synchronize with whatever task the worker is doing. This patch fixes both issues.

commitb1bc1050a909d0613791965a39ed579003663a01 authorAlexander Vershilov <alexander.vershilov@gmail.com> dateWed 11 Feb 2015, 22:59 (12 years ago) parenta386058

1 file changed+14−14

compare with master

unifiedsplit

src/Control/Distributed/Process.hs+14−14

src/Control/Distributed/Process.hs+14−14

@@ -163,7 +163,12 @@ import Prelude hiding (catch)

163163import Control.Monad.IO.Class (liftIO)

164164import Control.Applicative ((<$>))

165165import Control.Monad.Reader (ask)

166−import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

166+import Control.Concurrent.MVar

167+ ( MVar

168+ , newEmptyMVar

169+ , takeMVar

170+ , putMVar

171+ )

167172import Control.Distributed.Static

168173 ( Closure

169174 , closure

@@ -305,7 +310,7 @@ import Control.Distributed.Process.Internal.Spawn

305310 , spawnSupervised

306311 , call

307312 )

308−import Control.Exception (SomeException, throwIO)

313+import Control.Exception (SomeException, throw)

309314

310315-- INTERNAL NOTES

311316--

@@ -401,15 +406,10 @@ spawnChannelLocal proc = do

401406-- messages sent to the caller process, and also allows silently dropping late

402407-- or duplicate messages sent to the isolated process after it exits.

403408-- Silently dropping messages may not always be the best approach.

404−callLocal ::

405− Process a -- ^ Process to run

406− -> Process a -- ^ Value returned

407−callLocal proc = do

408− mv <- liftIO newEmptyMVar

409− self <- getSelfPid

410− _ <- spawnLocal $ do

411− link self

412− try proc >>= liftIO . putMVar mv

413− liftIO $ takeMVar mv >>=

414− either (throwIO :: SomeException -> IO a) return

415−

409+callLocal :: Process a -> Process a

410+callLocal proc = mask $ \release -> do

411+ mv <- liftIO newEmptyMVar :: Process (MVar (Either SomeException a))

412+ child <- spawnLocal $ try (release proc) >>= liftIO . putMVar mv

413+ rs <- liftIO (takeMVar mv) `onException`

414+ (kill child "exception in parent process" >> liftIO (takeMVar mv))

415+ either throw return rs