Asynchronous exception wormholes kill modularity

[Bas van Dijk]

Dear all, (sorry for this long mail)

When programming in the IO monad you have to be careful about
asynchronous exceptions. These nasty little worms can be thrown to you
at any point in your IO computation. You have to be extra careful when
doing, what must be, an atomic transaction like:

do old <- takeMVar m
   new <- f old `onException` putMVar m old
   putMVar m new

If an asynchronous exception is thrown to you right after you have
taken your MVar the putMVar will not be executed anymore and will
leave your MVar in the empty state. This can possibly lead to
dead-lock.

The standard solution for this is to use a function like modifyMVar_:

modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
modifyMVar_ m io =
  block $ do
    a  <- takeMVar m
    a' <- unblock (io a) `onException` putMVar m a
    putMVar m a'

As you can see this will first block asynchronous exceptions before
taking the MVar.

It is usually better to be in the blocked state as short as possible
to ensure that asynchronous exceptions can be handled as soon as
possible. This is why modifyMVar_ unblocks the the inner (io a).

However now comes the problem I would like to talk about. What if I
want to use modifyMVar_ as part of a bigger atomic transaction. As in:

block $ do ...
           modifyMVar_ m f
           ...

>From a quick glanse at this code it looks like asynchronous exceptions
can't be thrown to this transaction because we block them. However the
unblock in modifyMVar_ opens an asynchronous exception "wormhole"
right into our blocked computation. This destroys modularity.

Besides modifyMVar_ the following functions suffer the same problem:

* Control.Exception.finally/bracket/bracketOnError
* Control.Concurrent.MVar.withMVar/modifyMVar_/modifyMVar
* Foreign.Marshal.Pool.withPool

We can solve it by introducing two handy functions 'blockedApply' and
'blockedApply2' and wrapping each of the operations in them:

> import Control.Exception
> import Control.Concurrent.MVar
> import Foreign.Marshal.Pool
> import GHC.IO ( catchAny )


> blockedApply :: IO a -> (IO a -> IO b) -> IO b
> blockedApply a f = do
>   b <- blocked
>   if b
>     then f a
>     else block $ f $ unblock a

> blockedApply2 :: (c -> IO a) -> ((c -> IO a) -> IO b) -> IO b
> blockedApply2 g f = do
>   b <- blocked
>   if b
>     then f g
>     else block $ f $ unblock . g


Control.Exception:

> finally :: IO a -> IO b -> IO a
> a `finally` sequel = blockedApply a $ \a' -> do
>   r <- a' `onException` sequel
>   _ <- sequel
>   return r

> bracket :: IO a-> (a -> IO b) -> (a -> IO c) -> IO c
> bracket before after thing = blockedApply2 thing $ \thing' -> do
>   a <- before
>   r <- thing' a `onException` after a
>   _ <- after a
>   return r

> bracketOnError :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
> bracketOnError before after thing = blockedApply2 thing $ \thing' -> do
>   a <- before
>   thing' a `onException` after a


Control.Concurrent.MVar:

> withMVar :: MVar a -> (a -> IO b) -> IO b
> withMVar m io = blockedApply2 io $ \io' -> do
>   a <- takeMVar m
>   b <- io' a `onException` putMVar m a
>   putMVar m a
>   return b

> modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
> modifyMVar_ m io = blockedApply2 io $ \io' -> do
>   a  <- takeMVar m
>   a' <- io' a `onException` putMVar m a
>   putMVar m a'

> modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
> modifyMVar m io = blockedApply2 io $ \io' -> do
>   a      <- takeMVar m
>   (a',b) <- io' a `onException` putMVar m a
>   putMVar m a'
>   return b


Foreign.Marshal.Pool:

> withPool :: (Pool -> IO b) -> IO b
> withPool act = blockedApply2 act $ \act' -> do
>   pool <- newPool
>   val <- catchAny
>             (act' pool)
>             (\e -> do freePool pool; throw e)
>   freePool pool
>   return val


I'm not proposing to make this change (yet) because I first would like
to have some discussion on this.

Thanks for reading this rather long mail,

Bas