Thanks very much for these ideas. Peter Verswyvelen suggested running the
example repeatedly to see if it always runs correctly. He found, and I
verified, that the example runs fine with Bertram's last version of unamb
below, *unless* it's compiled with -threaded and run with +RTS -N2. In the
latter case, it locks up after a while.
I also tried a version with brackAsync and found that it eventually locks up
even under ghci. When compiled & run multi-threaded, it locks up almost
immediately.
I've attached a module, TestRace.hs, containing these experiments.
- Conal
On Sat, Dec 27, 2008 at 6:03 PM, Bertram Felgenhauer <
bertram.felgenha...@googlemail.com> wrote:
> Sterling Clover wrote:
> > On Dec 27, 2008, at 9:02 AM, Bertram Felgenhauer wrote:
> >> In the above code, there is a small window between catching the
> >> ThreadKilled exception and throwing it again though, where other
> >> exceptions may creep in. The only way I see of fixing that is to use
> >> 'block' and 'unblock' directly.
> >
> > That certainly seems to do the trick for the simple example at least. One
> > way to reason about it better would be, instead of folding everything
> into
> > the race function, to simply modify ghc's bracket function to give us the
> > behavior we'd prefer (speaking of which, I recall there's something in
> the
> > works for 6.12 or so to improve rethrowing of asynchronous exceptions?)
> >
> > brackAsync before after thing =
> > block (do
> > a <- before
> > r <- catch
> > (unblock (thing a))
> > (\_ -> after a >> myThreadId >>= killThread >>
> > brackAsync before after thing )
> > after a
> > return r
> > )
> > where threadKilled ThreadKilled = Just ()
> > threadKilled _ = Nothing
>
> This code turns any exception into ThreadKilled further down the stack.
>
> (\e -> do
> after a
> myThreadId >>= flip throwTo (e :: SomeException)
> ...
>
> might do the trick.
>
> My assumption was that anything but 'ThreadKilled' would be a
> real error. This isn't really true, I guess - thanks to throwTo,
> any exception could be asynchronous.
>
> If an exception is thrown, 'after a' is run again after the computation
> has resumed.
>
> That's why I did the cleanup within the 'catch'.
>
> But there's no reason why you couldn't do that as well:
>
> brackAsync before after thing =
> block $ do
> a <- before
> catch (unblock (thing a) >>= \r -> after a >> return r) $
> \e -> do
> after a
> myThreadId >>= flip throwTo (e :: SomeException)
> brackAsync before after thing )
>
> > This brackAsync just drops in to the previous code where bracket was and
> > appears to perform correctly.
>
> Right. 'race' should also unblock exceptions in the worker threads,
>
> withThread u v = brackAsync (forkIO (unblock u)) killThread (const v)
>
> but that's an independent change.
>
> > Further, if we place a trace after the
> > killThread, we se it gets executed once when the example is read (i.e. a
> > resumption) but it does not get executed if the (`seq` v) is removed from
> > the example So this gives me some hope that this is actually doing what
> > we'd like. I don't doubt it may have further kinks however.
>
> At least the GHC RTS has support for the hard part - unwinding the stack
> so that computations can be resumed seamlessly.
>
> I'm not sure which of the approaches I like better - it seems that we
> have a choice between turning async exceptions into sync ones or vice
> versa, and neither choice is strictly superior to the other.
>
> Enjoy,
>
> Bertram
>
> 'race' update:
> - Bugfix: Previously, only AsyncException-s would be caught.
> Use 'fromException' to select the ThreadKilled exception.
> - I tried using a custom 'SuspendException' type, but this resulted in
> 'test: SuspendException' messages on the console, while ThreadKilled
> is silently ignored... as documented:
>
> http://www.haskell.org/ghc/docs/latest/html/libraries/base/Control-Concurrent.html#v%3AforkIO
> (http://tinyurl.com/9t5pxs)
> - Tweak: Block exceptions while running 'cleanup' to avoid killing
> threads twice.
> - Trick: takeMVar is a blocking operation, so exceptions can be
> delivered while it's waiting - there's no need to use 'unblock' for
> this. In other words, unblock (takeMVar v) and takeMVar v are
> essentially equivalent for our purposes.
>
> race :: IO a -> IO a -> IO a
> race a b = block $ do
> v <- newEmptyMVar
> let t x = unblock (x >>= putMVar v)
> ta <- forkIO (t a)
> tb <- forkIO (t b)
> let cleanup = killThread ta >> killThread tb
> (do r <- takeMVar v; cleanup; return r) `catch`
> \e -> cleanup >>
> case fromException e of
> Just ThreadKilled -> do
> myThreadId >>= killThread
> unblock (race a b)
> _ -> throwIO e
> _______________________________________________
> Reactive mailing list
> react...@haskell.org
> http://www.haskell.org/mailman/listinfo/reactive
>
{-# OPTIONS_GHC -Wall #-}
-- TestRace.hs. Compile & run:
-- ghc --make -threaded TestRace.hs
-- ./TestRace +RTS -N2
-- Prints consecutive natural numbers for a while, and then gets stuck.
-- Seems to run fine without -threaded/N2
import Prelude hiding (catch)
import System.IO.Unsafe
import Control.Monad.Instances () -- for function functor
import Control.Concurrent
import Control.Exception
test :: Int -> Int
test x = f (f x) where f v = (x `unamb` v) `seq` v
main :: IO ()
main = mapM_ (print . test) [0..]
unamb :: a -> a -> a
a `unamb` b = unsafePerformIO (evaluate a `race` evaluate b)
-- | Race two actions against each other in separate threads, and pick
-- whichever finishes first. See also 'amb'.
race :: IO a -> IO a -> IO a
-- -- Old version. Doesn't take care to recursively terminate descendent
-- -- threads. This version seems to work forever, but with degraded
-- -- performance. I guess there are more & more useless live threads.
-- a `race` b = do v <- newEmptyMVar
-- let f x = forkIO (putCatch x v)
-- ta <- f a
-- tb <- f b
-- x <- takeMVar v
-- killThread ta
-- killThread tb
-- return x
-- -- New version, based on suggestions from Sterling Clover and Bertram
-- -- Felgenhauer. This one seems to work correctly and perform well, unless
-- -- compiled with -threaded and run with +RTS -N2, which leads to lock-up
-- -- after a while.
-- race a b = block $ do
-- v <- newEmptyMVar
-- let f x = forkIO (unblock (putCatch x v))
-- ta <- f a
-- tb <- f b
-- let cleanup = killThread ta >> killThread tb
-- (do r <- takeMVar v; cleanup; return r) `catch`
-- \e -> do cleanup
-- case fromException e of
-- Just ThreadKilled ->
-- -- kill self synchronously and then retry if
-- -- evaluated again.
-- do myThreadId >>= killThread
-- unblock (race a b)
-- _ -> throwIO e
-- This one locks up after a while even in ghci. When compiled -threaded
-- and run +RTS -N2, it locks up almost immediately.
a `race` b = do
v <- newEmptyMVar
let t x = x >>= putMVar v
withThread (t a) $ withThread (t b) $ takeMVar v
where
withThread u v = brackAsync (forkIO u) killThread (const v)
brackAsync :: IO t -> (t -> IO b) -> (t -> IO a) -> IO a
brackAsync before after thing =
block $ do
a <- before
catch (unblock (thing a) >>= \r -> after a >> return r) $
\e -> do
after a
myThreadId >>= flip throwTo (e :: SomeException)
brackAsync before after thing
putCatch :: IO a -> MVar a -> IO ()
putCatch act v = (act >>= putMVar v) `catches`
[ Handler $ \ (ErrorCall _) -> return ()
, Handler $ \ BlockedOnDeadMVar -> return ()
-- This next handler hides bogus black holes, which show up as
-- "<<loop>>" messages. I'd rather eliminate the problem than hide it.
-- , Handler $ \ NonTermination -> return ()
]
_______________________________________________
Glasgow-haskell-users mailing list
Glasgow-haskell-users@haskell.org
http://www.haskell.org/mailman/listinfo/glasgow-haskell-users
