[commit: packages/base] master: Handle ExitFailure (-sig) by killing process with signal (6b22a6e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/base

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/6b22a6ef9e59c6562ef6adfad7cd94e27aedec2c/base

>---------------------------------------------------------------

commit 6b22a6ef9e59c6562ef6adfad7cd94e27aedec2c
Author: Duncan Coutts <duncan at well-typed.com>
Date:   Thu Nov 14 15:15:31 2013 +0000

    Handle ExitFailure (-sig) by killing process with signal
    
    On Unix we now use negative exit codes in ExitFailure to indicate that a
    process exited due to a signal. This patch implements the case for when
    a ExitFailure exception propagates out of the top of main (and is
    handled by the topHandler).
    
    For a negative ExitFailure code, we try to kill the process using that
    signal (the details of that are handled by shutdownHaskellAndSignal from
    the RTS). For an exit code outside the valid ranges, we use 0xff.


>---------------------------------------------------------------

6b22a6ef9e59c6562ef6adfad7cd94e27aedec2c
 GHC/TopHandler.lhs |   40 +++++++++++++++++++++++++++++-----------
 1 file changed, 29 insertions(+), 11 deletions(-)

diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs
index 9e4bc07..8e50333 100644
--- a/GHC/TopHandler.lhs
+++ b/GHC/TopHandler.lhs
@@ -177,10 +177,32 @@ flushStdHandles = do
   hFlush stdout `catchAny` \_ -> return ()
   hFlush stderr `catchAny` \_ -> return ()
 
+safeExit, fastExit :: Int -> IO a
+safeExit = exitHelper useSafeExit
+fastExit = exitHelper useFastExit
+
+exitHelper :: CInt -> Int -> IO a
 -- we have to use unsafeCoerce# to get the 'IO a' result type, since the
 -- compiler doesn't let us declare that as the result type of a foreign export.
-safeExit :: Int -> IO a
-safeExit r = unsafeCoerce# (shutdownHaskellAndExit $ fromIntegral r)
+#ifdef mingw32_HOST_OS
+exitHelper exitKind r =
+  unsafeCoerce# (shutdownHaskellAndExit (fromIntegral r) exitKind)
+#else
+-- On Unix we use an encoding for the ExitCode:
+--      0 -- 255  normal exit code
+--   -127 -- -1   exit by signal
+-- For any invalid encoding we just use a replacement (0xff).
+exitHelper exitKind r
+  | r >= 0 && r <= 255
+  = unsafeCoerce# (shutdownHaskellAndExit   (fromIntegral   r)  exitKind)
+  | r >= -127 && r <= -1
+  = unsafeCoerce# (shutdownHaskellAndSignal (fromIntegral (-r)) exitKind)
+  | otherwise
+  = unsafeCoerce# (shutdownHaskellAndExit   0xff                exitKind)
+
+foreign import ccall "shutdownHaskellAndSignal"
+  shutdownHaskellAndSignal :: CInt -> CInt -> IO ()
+#endif
 
 exitInterrupted :: IO a
 exitInterrupted = 
@@ -189,20 +211,16 @@ exitInterrupted =
 #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 ()
+  safeExit (-CONST_SIGINT)
 #endif
 
 -- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
 -- re-enter Haskell land through finalizers.
 foreign import ccall "Rts.h shutdownHaskellAndExit"
-  shutdownHaskellAndExit :: CInt -> IO ()
+  shutdownHaskellAndExit :: CInt -> CInt -> IO ()
 
-fastExit :: Int -> IO a
-fastExit r = unsafeCoerce# (stg_exit (fromIntegral r))
+useFastExit, useSafeExit :: CInt
+useFastExit = 1
+useSafeExit = 0
 
-foreign import ccall "Rts.h stg_exit"
-  stg_exit :: CInt -> IO ()
 \end{code}