Handle ExitFailure (-sig) by killing process with signal
authorDuncan Coutts <duncan@well-typed.com>
Thu, 14 Nov 2013 15:15:31 +0000 (15:15 +0000)
committerDuncan Coutts <duncan@well-typed.com>
Thu, 14 Nov 2013 15:15:31 +0000 (15:15 +0000)
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.

GHC/TopHandler.lhs

index 9e4bc07..8e50333 100644 (file)
@@ -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}