[reactive] Bug fixes in progress

[Bertram Felgenhauer]

Svein Ove Aas wrote:
> - I've rewritten unamb, fixing all the issues I've managed to find
>   (relating to nested unamb invocations, mostly) and having it throw a
>   BothBottom exception if both values are a finite bottom.

Can you name those issues? The old code only handled ThreadKilled
properly (because this is the most important exception to get right;
I didn't really give the others much thought.) What other problems
were there?

I like moving the retry logic to unamb, because IO actions should never
have to worry about being restarted. Only pure functions that use
unsafePerformIO will have to worry.

(further down the thread)
> This breaks my mental model of how unsafePerformIO actually works
> somewhat. I'm going to have to chat with #ghc before I can write any
> comments.

Isaac's answer is correct. I'll elaborate.

unsafePerformIO "just" creates a RealWorld# token out of thin air. From
the RTS' perspective it's indistinguishable from a pure computation.

The real issue is how exceptions are handled. On receiving an exception,
the RTS stack is unwound to the first exception handling frame. The most
important part is what happens to update frames. (Each update frame
corresponds to a thunk that the current thread has entered.)

For synchronous exceptions (throw/throwIO), those pending updates are
performed to reflect the error: the corresponding thunks are replaced
by a thunk that rethrows the exception. This has the advantage that
reevaluating those thunks is fast, and that it cures a potential space
leak.

For asynchronous exceptions (throwTo), the RTS has to cope with the
fact that the update frames may correspond to a pure computation, so
it has to arrange for the computation to be resumed. So what it does
is turn the update frames into thunks that, when entered, reconstruct
the stack frames and continue the term's evaluation. The exception is
not rethrown when the computation is resumed.

Most of the gory details are in raiseAsync() in rts/RaiseException.c
in the ghc sources.

[...]
> module Data.Unamb
[...]
> unamb :: a -> a -> a
> unamb a b = unsafePerformIO $ do 
>               -- First, check whether one of the values already is evaluated
>               -- #ifdef this for GHC
>               a' <- return False --isEvaluated a
>               b' <- return False --isEvaluated b
>               case (a',b') of
>                 (True,_)        -> return a
>                 (_,True)        -> return b
>                 otherwise       -> do retry (amb a b)
>     where retry act = act `catch`
>                         (\(SomeException e) -> do
>                              -- The throwTo is apparently needed, to ensure the
>                              -- exception is thrown to *this* thread.
>                              -- unsafePerformIO would otherwise restart the
>                              -- throwIO call when re-invoked.
> --                              print "abort"
>                              myid <- myThreadId
>                              unblock $ throwTo myid e >> retry act)

Would it make sense to do the isEvaluated checks again when retrying?

Obscure fact:  throwTo myid e  works even if exceptions are blocked in
the current thread. (Rationale: throwTo is a blocking operation; if
it blocks, exceptions can be delivered regardless of 'block' or
'unblock') So you could write

  retry act = unblock act `catch` \(SomeException e) -> do
                  myid <- myThreadId
                  -- Kill this thread. We need to rethrow the exception
                  -- as an /asynchronous/ exception to ensure that this
                  -- computation can be restarted.
                  throwTo myid e
                  retry act

> -- | Race two actions against each other in separate threads, and pick
> -- whichever finishes first.  See also 'amb'.
> race :: IO a -> IO a -> IO a
>
> -- Here is an improved version, based on suggestions from Sterling Clover
> -- and Bertram Felgenhauer.  It takes care to kill children when killed.
> -- Importantly, it also sets itself up to be retried if the unamb value is
> -- accessed again after its computation is aborted.
> 
> -- 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 asynchronously and then retry if
> --                       -- evaluated again.
> --                       do throwIO e

This throwIO e was not in the original code, and indeed it would produce
non-restartable behaviour. Please remove that line.

> --                          myThreadId >>= killThread
> --                          unblock (race a b)
> --                     _ -> throwIO e
> 
> -- Finally, an improved version written by Svein Ove Aas
> 
> -- This version kills descendant threads when killed, but does not restart
> -- any work if it's called by unamb. That code is left in unamb.
> 
> race a b = block $ do
>   v <- newEmptyMVar
>   let f x = forkIO $ putCatch x v
>   ta <- f a
>   tb <- f b
>   let cleanup = killThread ta >> killThread tb
>       loop 0 = throwIO BothBottom
>       loop t = do x <- takeMVar v
>                   case x of Nothing -> loop (t-1)
>                             Just x' -> return x'
>   unblock (loop (2 :: Int) `finally` cleanup)

Okay, by signaling finite bottoms with Nothing you avoid having to wait
for a garbage collection to detect the case of two finite bottoms,
which would deliver a BlockedOnDeadMVar exception to the 'race' thread
with the old code.

> -- A thread can bottom-out efficiently by throwing that exception.
> -- Before a thread bails out for any reason, it informs race of its bailing out.
> 
> -- Execute a given action and store the result in an MVar. Catch
> -- all errors, bypassing the MVar write and registering a dead thread in that
> -- mvar before passing them on.
> -- We suppress error-printing for.. what, exactly? When should we *not* do it?

Good question, are there any exceptions here that we want to see?
I guess there are a few. Hiding stack overflows would be a bad thing,
for example.

> -- Using old code for now.
> putCatch :: IO a -> MVar (Maybe a) -> IO ()
> putCatch act v = onException (act >>= putMVar v . Just) (putMVar v Nothing) `catches`
>                  [ Handler $ \ ErrorCall         {} -> return ()
>                  , Handler $ \ BothBottom        {} -> return ()
>                  , Handler $ \ PatternMatchFail  {} -> 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    -> print "Unamb.hs: Bogus black hole?" >> throwIO NonTermination
>                  ]

Regards,

Bertram