FIX part of #2301

Control-C now causes the new exception (AsyncException UserInterrupt)
to be raised in the main thread.  The signal handler is set up by
GHC.TopHandler.runMainIO, and can be overriden in the usual way by
installing a new signal handler.  The advantage is that now all
programs will get a chance to clean up on ^C.

When UserInterrupt is caught by the topmost handler, we now exit the
program via kill(getpid(),SIGINT), which tells the parent process that
we exited as a result of ^C, so the parent can take appropriate action
(it might want to exit too, for example).

One subtlety is that we have to use a weak reference to the ThreadId
for the main thread, so that the signal handler doesn't prevent the
main thread from being subject to deadlock detection.

diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs
index a11ec62..168daf3 100644 (file)
--- a/GHC/IOBase.lhs
+++ b/GHC/IOBase.lhs
@@ -742,6 +742,10 @@ data AsyncException
         -- calling 'Control.Concurrent.killThread', or by the system
         -- if it needs to terminate the thread for some
         -- reason.
+  | UserInterrupt
+        -- ^This exception is raised by default in the main thread of
+        -- the program when the user requests to terminate the program
+        -- via the usual mechanism(s) (e.g. Control-C in the console).
   deriving (Eq, Ord)
 
 -- | Exceptions generated by array operations

diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs
index c983e34..7077073 100644 (file)
--- a/GHC/TopHandler.lhs
+++ b/GHC/TopHandler.lhs
@@ -22,21 +22,80 @@ module GHC.TopHandler (
    reportStackOverflow, reportError,
   ) where
 
+#include "HsBaseConfig.h"
+
 import Prelude
 
 import System.IO
 import Control.Exception
+import Control.Concurrent.MVar
 
-import Foreign.C        ( CInt )
+import Foreign
+import Foreign.C
 import GHC.IOBase
 import GHC.Exception
-import GHC.Prim (unsafeCoerce#)
+import GHC.Prim
+import GHC.Conc
+import GHC.Weak
 
 -- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
 -- called in the program).  It catches otherwise uncaught exceptions,
 -- and also flushes stdout\/stderr before exiting.
 runMainIO :: IO a -> IO a
-runMainIO main = (do a <- main; cleanUp; return a) `catchException` topHandler
+runMainIO main = 
+    do 
+      main_thread_id <- myThreadId
+      weak_tid <- mkWeakThreadId main_thread_id
+      install_interrupt_handler $ do
+           m <- deRefWeak weak_tid 
+           case m of
+               Nothing  -> return ()
+               Just tid -> throwTo tid (AsyncException UserInterrupt)
+      a <- main
+      cleanUp
+      return a
+    `catchException`
+      topHandler
+
+install_interrupt_handler :: IO () -> IO ()
+#ifdef mingw32_HOST_OS
+install_interrupt_handler handler = 
+  GHC.ConsoleHandler.installHandler $
+     Catch $ \event -> 
+        case event of
+           ControlC -> handler
+           Break    -> handler
+           Close    -> handler
+           _ -> return ()
+#else
+#include "Signals.h"
+-- specialised version of System.Posix.Signals.installHandler, which
+-- isn't available here.
+install_interrupt_handler handler = do
+   let sig = CONST_SIGINT :: CInt
+   withMVar signalHandlerLock $ \_ ->
+     alloca $ \p_sp -> do
+       sptr <- newStablePtr handler
+       poke p_sp sptr
+       stg_sig_install sig STG_SIG_RST p_sp nullPtr
+       return ()
+
+foreign import ccall unsafe
+  stg_sig_install
+       :: CInt                         -- sig no.
+       -> CInt                         -- action code (STG_SIG_HAN etc.)
+       -> Ptr (StablePtr (IO ()))      -- (in, out) Haskell handler
+       -> Ptr ()                       -- (in, out) blocked
+       -> IO CInt                      -- (ret) action code
+#endif
+
+-- make a weak pointer to a ThreadId: holding the weak pointer doesn't
+-- keep the thread alive and prevent it from being identified as
+-- deadlocked.  Vitally important for the main thread.
+mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
+mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
+   case mkWeak# t# t (unsafeCoerce# 0#) s of 
+      (# s1, w #) -> (# s1, Weak w #)
 
 -- | 'runIO' is wrapped around every @foreign export@ and @foreign
 -- import \"wrapper\"@ to mop up any uncaught exceptions.  Thus, the
@@ -89,6 +148,8 @@ real_handler exit exn =
            reportStackOverflow
            exit 2
 
+        AsyncException UserInterrupt  -> exitInterrupted
+
         -- only the main thread gets ExitException exceptions
         ExitException ExitSuccess     -> exit 0
         ExitException (ExitFailure n) -> exit n
@@ -128,6 +189,19 @@ cleanUpAndExit r = do cleanUp; safeExit r
 safeExit :: Int -> IO a
 safeExit r = unsafeCoerce# (shutdownHaskellAndExit $ fromIntegral r)
 
+exitInterrupted :: IO a
+exitInterrupted = 
+#ifdef mingw32_HOST_OS
+  safeExit 252
+#else
+  -- we must exit via the default action for SIGINT, so that the
+  -- parent of this process can take appropriate action (see #2301)
+  unsafeCoerce# (shutdownHaskellAndSignal CONST_SIGINT)
+
+foreign import ccall "shutdownHaskellAndSignal"
+  shutdownHaskellAndSignal :: CInt -> IO ()
+#endif
+
 -- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
 -- re-enter Haskell land through finalizers.
 foreign import ccall "Rts.h shutdownHaskellAndExit"