rts_checkSchedStatus: exit the thread, not the process, when Interrupted

This means that when the process is shutting down, if we have calls to
foreign exports in progress, they get forcibly terminated as before,
but now they only shut down the calling thread rather than the whole
process (with -threaded).

This came up in a discussion started by Akio Takano on ghc-users.

1 files changed, 10 insertions, 1 deletions

diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c
index ec19b169b6..720b732323 100644
--- a/rts/RtsAPI.c
+++ b/rts/RtsAPI.c
@@ -522,7 +522,16 @@ rts_checkSchedStatus (char* site, Capability *cap)
 	stg_exit(EXIT_FAILURE);
     case Interrupted:
 	errorBelch("%s: interrupted", site);
-	stg_exit(EXIT_FAILURE);
+#ifdef THREADED_RTS
+        // The RTS is shutting down, and the process will probably
+        // soon exit.  We don't want to preempt the shutdown
+        // by exiting the whole process here, so we just terminate the
+        // current thread.  Don't forget to release the cap first though.
+        rts_unlock(cap);
+        shutdownThread();
+#else
+        stg_exit(EXIT_FAILURE);
+#endif
     default:
 	errorBelch("%s: Return code (%d) not ok",(site),(rc));	
 	stg_exit(EXIT_FAILURE);