From dc7d10ab6183a0fe43227c0d37b74a59fc8687d7 Mon Sep 17 00:00:00 2001 From: Joey Adams Date: Sun, 12 Feb 2012 16:08:07 -0500 Subject: [PATCH] Sealed writeChan with mask_ to prevent a theoretical bug --- Control/Concurrent/Chan.hs | 18 +++++++++++++++--- 1 files changed, 15 insertions(+), 3 deletions(-) diff --git a/Control/Concurrent/Chan.hs b/Control/Concurrent/Chan.hs index 23b21bb..2b84503 100644 --- a/Control/Concurrent/Chan.hs +++ b/Control/Concurrent/Chan.hs @@ -40,6 +40,7 @@ import Prelude import System.IO.Unsafe ( unsafeInterleaveIO ) import Control.Concurrent.MVar +import Control.Exception (mask_) import Data.Typeable #include "Typeable.h" @@ -51,7 +52,7 @@ import Data.Typeable -- |'Chan' is an abstract type representing an unbounded FIFO channel. data Chan a = Chan (MVar (Stream a)) - (MVar (Stream a)) + (MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar deriving Eq INSTANCE_TYPEABLE1(Chan,chanTc,"Chan") @@ -83,9 +84,20 @@ newChan = do writeChan :: Chan a -> a -> IO () writeChan (Chan _ writeVar) val = do new_hole <- newEmptyMVar - modifyMVar_ writeVar $ \old_hole -> do + mask_ $ do + old_hole <- takeMVar writeVar putMVar old_hole (ChItem val new_hole) - return new_hole + putMVar writeVar new_hole + +-- The reason we don't simply do this: +-- +-- modifyMVar_ writeVar $ \old_hole -> do +-- putMVar old_hole (ChItem val new_hole) +-- return new_hole +-- +-- is because if an asynchronous exception is received after the 'putMVar' +-- completes and before modifyMVar_ installs the new value, it will set the +-- Chan's write end to a filled hole. -- |Read the next value from the 'Chan'. readChan :: Chan a -> IO a -- 1.7.0.4