FFI, signals and exceptions

[Edward Z. Yang]

Excerpts from Simon Marlow's message of Thu Aug 26 04:08:06 -0400 2010:
> You don't want to do this for a bound thread (when target->bound != 
> NULL), because the OS thread will have interesting things on its C stack 
> and pthread_cancel discards the entire stack.  A worker thread on the 
> other hand has an uninteresting stack and we can easily make another one.

It seems possible that under certain (limited) circumstances, this would
be desirable behavior: for example, if we truly wanted to destroy the bound
thread-local state and start over from scratch.

> So you don't want to do blockedThrowTo, instead call raiseAsync to raise 
> the exception, and that should put the TSO back on the the run queue.

With:

    raiseAsync(cap, target, msg->exception, rtsFalse, NULL)
    // ....
    return THROWTO_SUCCESS;

the thread is successfully able to catch the exception!

        case BlockedOnCCall:
        case BlockedOnCCall_NoUnblockExc:
        {
    #ifdef THREADED_RTS
            Task *task = NULL;
            raiseAsync(cap, target, msg->exception, rtsFalse, NULL);
            if (!target->bound) {
                // walk all_tasks to find the correct worker thread
                for (task = all_tasks; task != NULL; task = task->all_link) {
                    if (task->incall->suspended_tso == target) {
                        break;
                    }
                }
            }
            if (task != NULL) {
                pthread_cancel(task->id);
                task->cap = NULL;
                task->stopped = rtsTrue;
            }
            return THROWTO_SUCCESS;
    #else
            blockedThrowTo(cap,target,msg);
            return THROWTO_BLOCKED;
    #endif
        }

Here is a new (working) implementation interruptible:

    interruptible :: a -> IO a -> IO a
    interruptible defaultVal m = do
        mresult <- newEmptyMVar -- transfer exception to caller
        mtid    <- newEmptyMVar
        let install = do
                installIntHandler (Catch ctrlc)
            cleanup oldHandler = do
                _ <- installIntHandler oldHandler
                return ()
            ctrlc = do
                hPutStrLn stderr "Caught signal"
                tid <- readMVar mtid
                throwTo tid E.UserInterrupt
            bracket = reportBracket . E.bracket install cleanup . const
            reportBracket action = do
                putMVar mresult =<< E.catches (liftM Right action)
                    [ E.Handler (\(e :: E.AsyncException) ->
                        return $ case e of
                            E.UserInterrupt -> Right defaultVal
                            _ -> Left (E.toException e)
                        )
                    , E.Handler (\(e :: E.SomeException) -> return (Left e))
                    ]
        putMVar mtid =<< forkIO (bracket m)
        either E.throw return =<< readMVar mresult -- one write only

Do you have any suggestions for stress-testing this code?

Cheers,
Edward