Improve the shutdownHaskellAndSignal and add fast exit

This is the RTS part of a patch to base's topHandler to handle exiting
by a signal.

The intended behaviour is that on Unix, throwing ExitFailure (-sig)
results in the process terminating with that signal. Previously
shutdownHaskellAndSignal was only used for exiting with SIGINT due to
the UserInterrupt exception.

Improve shutdownHaskellAndSignal to do the signal part more carefully.
In particular, it (should) now reliably terminates the process one way
or another. Previusly if the signal was blocked, ignored or handled then
shutdownHaskellAndSignal would actually return!

Also, the topHandler code has two paths a careful shutdown and a "fast
exit" where it does not give finalisers a chance to run. We want to
support that mode also when we want to exit by signal. So rather than
the base code directly calling stg_exit as it did before, we have a
fastExit bool paramater for both shutdownHaskellAnd{Exit,Signal}.

3 files changed, 60 insertions, 16 deletions

diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
index 29c28d8fcc..daae30b821 100644
--- a/includes/RtsAPI.h
+++ b/includes/RtsAPI.h
@@ -94,14 +94,12 @@ extern void hs_init_with_rtsopts (int *argc, char **argv[]);
 extern void hs_init_ghc (int *argc, char **argv[],   // program arguments
                          RtsConfig rts_config);      // RTS configuration
 
-extern void shutdownHaskellAndExit ( int exitCode )
-#if __GNUC__ >= 3
-    __attribute__((__noreturn__))
-#endif
-    ;
+extern void shutdownHaskellAndExit (int exitCode, int fastExit)
+    GNUC3_ATTRIBUTE(__noreturn__);
 
 #ifndef mingw32_HOST_OS
-extern void shutdownHaskellAndSignal (int sig);
+extern void shutdownHaskellAndSignal (int sig, int fastExit)
+     GNUC3_ATTRIBUTE(__noreturn__);
 #endif
 
 extern void getProgArgv            ( int *argc, char **argv[] );
diff --git a/rts/RtsMain.c b/rts/RtsMain.c
index 435df420c5..df637169f8 100644
--- a/rts/RtsMain.c
+++ b/rts/RtsMain.c
@@ -84,7 +84,7 @@ static void real_main(void)
     default:
       barf("main thread completed with invalid status");
     }
-    shutdownHaskellAndExit(exit_status);
+    shutdownHaskellAndExit(exit_status, 0 /* !fastExit */);
 }
 
 /* The rts entry point from a compiled program using a Haskell main
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index a1c74ae6a6..aa7306f88a 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -455,24 +455,70 @@ shutdownHaskell(void)
 }
 
 void
-shutdownHaskellAndExit(int n)
+shutdownHaskellAndExit(int n, int fastExit)
 {
-    // even if hs_init_count > 1, we still want to shut down the RTS
-    // and exit immediately (see #5402)
-    hs_init_count = 1;
+    if (!fastExit) {
+        // even if hs_init_count > 1, we still want to shut down the RTS
+        // and exit immediately (see #5402)
+        hs_init_count = 1;
 
-    // we're about to exit(), no need to wait for foreign calls to return.
-    hs_exit_(rtsFalse);
+        // we're about to exit(), no need to wait for foreign calls to return.
+        hs_exit_(rtsFalse);
+    }
 
     stg_exit(n);
 }
 
 #ifndef mingw32_HOST_OS
+static void exitBySignal(int sig) GNUC3_ATTRIBUTE(__noreturn__);
+
 void
-shutdownHaskellAndSignal(int sig)
+shutdownHaskellAndSignal(int sig, int fastExit)
 {
-    hs_exit_(rtsFalse);
-    kill(getpid(),sig);
+    if (!fastExit) {
+        hs_exit_(rtsFalse);
+    }
+
+    exitBySignal(sig);
+}
+
+void
+exitBySignal(int sig)
+{
+    // We're trying to kill ourselves with a given signal.
+    // That's easier said that done because:
+    //  - signals can be ignored have handlers set for them
+    //  - signals can be masked
+    //  - signals default action can do things other than terminate:
+    //    + can do nothing
+    //    + can do weirder things: stop/continue the process
+
+    struct sigaction dfl;
+    sigset_t sigset;
+
+    // So first of all, we reset the signal to use the default action.
+    (void)sigemptyset(&dfl.sa_mask);
+    dfl.sa_flags = 0;
+    dfl.sa_handler = SIG_DFL;
+    (void)sigaction(sig, &dfl, NULL);
+
+    // Then we unblock the signal so we can deliver it to ourselves
+    sigemptyset(&sigset);
+    sigaddset(&sigset, sig);
+    sigprocmask(SIG_UNBLOCK, &sigset, NULL);
+
+    switch (sig) {
+      case SIGSTOP: case SIGTSTP: case SIGTTIN: case SIGTTOU: case SIGCONT:
+        // These signals stop (or continue) the process, so are no good for
+        // exiting.
+        exit(0xff);
+
+      default:
+        kill(getpid(),sig);
+        // But it's possible the signal is one where the default action is to
+        // ignore, in which case we'll still be alive... so just exit.
+        exit(0xff);
+    }
 }
 #endif