X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FPanic.lhs;h=0e1b59dead6441c109ea17e0d776f288eb67ef86;hb=3a7e2b3ad24b08dd68c96421d1ef94baa9b00c92;hp=4f78aabc24b16b2746d5becc2079ca6e74366e96;hpb=9d0c8f842e35dde3d570580cf62a32779f66a6de;p=ghc-hetmet.git

diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs
index 4f78aab..0e1b59d 100644
--- a/compiler/utils/Panic.lhs
+++ b/compiler/utils/Panic.lhs
@@ -15,7 +15,7 @@ module Panic
      ghcError, progName,
      pgmError,
 
-     panic, panicFastInt, assertPanic, trace,
+     panic, sorry, panicFastInt, assertPanic, trace,
      
      Exception.Exception(..), showException, try, tryMost, throwTo,
 
@@ -36,7 +36,8 @@ import GHC.ConsoleHandler
 #endif
 
 import Exception
-import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar )
+import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_,
+                            myThreadId )
 import Data.Dynamic
 import Debug.Trace	( trace )
 import System.IO.Unsafe	( unsafePerformIO )
@@ -60,12 +61,14 @@ ghcError e = Exception.throw e
 -- assumed to contain a location already, so we don't print one).
 
 data GhcException
-  = PhaseFailed String		-- name of phase 
-  		ExitCode	-- an external phase (eg. cpp) failed
-  | Interrupted			-- someone pressed ^C
-  | UsageError String		-- prints the short usage msg after the error
+  = PhaseFailed  String		-- name of phase 
+  		 ExitCode	-- an external phase (eg. cpp) failed
+  | Signal Int                  -- some other fatal signal (SIGHUP,SIGTERM)
+  | UsageError   String		-- prints the short usage msg after the error
   | CmdLineError String		-- cmdline prob, but doesn't print usage
-  | Panic String		-- the `impossible' happened
+  | Panic        String		-- the `impossible' happened
+  | Sorry        String		-- the user tickled something that's known not to work yet, 
+				-- and we're not counting it as a bug.
   | InstallationError String	-- an installation problem
   | ProgramError String		-- error in the user's code, probably
   deriving Eq
@@ -105,13 +108,18 @@ showGhcException (ProgramError str)
    = showString str
 showGhcException (InstallationError str)
    = showString str
-showGhcException (Interrupted)
-   = showString "interrupted"
+showGhcException (Signal n)
+   = showString "signal: " . shows n
 showGhcException (Panic s)
    = showString ("panic! (the 'impossible' happened)\n"
 		 ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
 	         ++ s ++ "\n\n"
 	         ++ "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n")
+showGhcException (Sorry s)
+   = showString ("sorry! (this is work in progress)\n"
+		 ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
+	         ++ s ++ "\n")
+
 
 throwGhcException :: GhcException -> a
 throwGhcException = Exception.throw
@@ -129,8 +137,9 @@ instance Typeable GhcException where
 Panics and asserts.
 
 \begin{code}
-panic, pgmError :: String -> a
+panic, sorry, pgmError :: String -> a
 panic    x = throwGhcException (Panic x)
+sorry    x = throwGhcException (Sorry x)
 pgmError x = throwGhcException (ProgramError x)
 
 --  #-versions because panic can't return an unboxed int, and that's
@@ -147,7 +156,7 @@ assertPanic file line =
 \end{code}
 
 \begin{code}
--- | tryMost is like try, but passes through Interrupted and Panic
+-- | tryMost is like try, but passes through UserInterrupt and Panic
 -- exceptions.  Used when we want soft failures when reading interface
 -- files, for example.
 
@@ -158,7 +167,7 @@ tryMost action = do r <- try action
                         Left se ->
                             case fromException se of
                                 -- Some GhcException's we rethrow,
-                                Just Interrupted -> throwIO se
+                                Just (Signal _)  -> throwIO se
                                 Just (Panic _)   -> throwIO se
                                 -- others we return
                                 Just _           -> return (Left se)
@@ -180,18 +189,27 @@ installSignalHandlers.
 \begin{code}
 installSignalHandlers :: IO ()
 installSignalHandlers = do
+  main_thread <- myThreadId
+  modifyMVar_ interruptTargetThread (return . (main_thread :))
+
   let
-      interrupt_exn = (toException Interrupted)
+      interrupt_exn = (toException UserInterrupt)
 
       interrupt = do
 	withMVar interruptTargetThread $ \targets ->
 	  case targets of
 	   [] -> return ()
 	   (thread:_) -> throwTo thread interrupt_exn
+
   --
 #if !defined(mingw32_HOST_OS)
-  _ <- installHandler sigQUIT (Catch interrupt) Nothing 
-  _ <- installHandler sigINT  (Catch interrupt) Nothing
+  _ <- installHandler sigQUIT  (Catch interrupt) Nothing 
+  _ <- installHandler sigINT   (Catch interrupt) Nothing
+  -- see #3656; in the future we should install these automatically for
+  -- all Haskell programs in the same way that we install a ^C handler.
+  let fatal_signal n = throwTo main_thread (Signal (fromIntegral n))
+  _ <- installHandler sigHUP   (Catch (fatal_signal sigHUP))  Nothing
+  _ <- installHandler sigTERM  (Catch (fatal_signal sigTERM)) Nothing
   return ()
 #else
   -- GHC 6.3+ has support for console events on Windows
@@ -203,7 +221,7 @@ installSignalHandlers = do
       sig_handler Break    = interrupt
       sig_handler _        = return ()
 
-  installHandler (Catch sig_handler)
+  _ <- installHandler (Catch sig_handler)
   return ()
 #endif