X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FPanic.lhs;h=e11b28faefe5078bf77752c8cb446c82833a72bc;hb=5a185e27def3ee8ace1704235eb277bc60c38618;hp=0e049b0cfbf1b7fc8a6d38fa3ab7aa7d1e58d0ea;hpb=ec197dfef33654dd16b5832905dad2e52f79f7ab;p=ghc-hetmet.git

diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs
index 0e049b0..e11b28f 100644
--- a/compiler/utils/Panic.lhs
+++ b/compiler/utils/Panic.lhs
@@ -17,8 +17,7 @@ module Panic
 
      panic, panicFastInt, assertPanic, trace,
      
-     Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
-     catchJust, throwTo,
+     Exception.Exception(..), showException, try, tryMost, throwTo,
 
      installSignalHandlers, interruptTargetThread
    ) where
@@ -37,11 +36,11 @@ 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 )
-import System.IO.Error hiding ( try )
 import System.Exit
 import System.Environment
 \end{code}
@@ -50,11 +49,7 @@ GHC's own exception type.
 
 \begin{code}
 ghcError :: GhcException -> a
-#if __GLASGOW_HASKELL__ >= 609
 ghcError e = Exception.throw e
-#else
-ghcError e = Exception.throwDyn e
-#endif
 
 -- error messages all take the form
 --
@@ -68,7 +63,7 @@ ghcError e = Exception.throwDyn e
 data GhcException
   = PhaseFailed String		-- name of phase 
   		ExitCode	-- an external phase (eg. cpp) failed
-  | Interrupted			-- someone pressed ^C
+  | 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
@@ -76,9 +71,7 @@ data GhcException
   | ProgramError String		-- error in the user's code, probably
   deriving Eq
 
-#if __GLASGOW_HASKELL__ >= 609
 instance Exception GhcException
-#endif
 
 progName :: String
 progName = unsafePerformIO (getProgName)
@@ -87,16 +80,8 @@ progName = unsafePerformIO (getProgName)
 short_usage :: String
 short_usage = "Usage: For basic information, try the `--help' option."
 
-#if __GLASGOW_HASKELL__ < 609
-showException :: Exception.Exception -> String
--- Show expected dynamic exceptions specially
-showException (Exception.DynException d) | Just e <- fromDynamic d 
-					 = show (e::GhcException)
-showException other_exn	       	 	 = show other_exn
-#else
 showException :: Exception e => e -> String
 showException = show
-#endif
 
 instance Show GhcException where
   showsPrec _ e@(ProgramError _) = showGhcException e
@@ -121,8 +106,8 @@ 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"
@@ -130,18 +115,10 @@ showGhcException (Panic s)
 	         ++ "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n")
 
 throwGhcException :: GhcException -> a
-#if __GLASGOW_HASKELL__ < 609
-throwGhcException = Exception.throwDyn
-#else
 throwGhcException = Exception.throw
-#endif
 
 handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
-#if __GLASGOW_HASKELL__ < 609
-handleGhcException = flip gcatchDyn
-#else
 handleGhcException = ghandle
-#endif
 
 ghcExceptionTc :: TyCon
 ghcExceptionTc = mkTyCon "GhcException"
@@ -171,66 +148,29 @@ 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.
 
-#if __GLASGOW_HASKELL__ < 609
-tryMost :: IO a -> IO (Either Exception.Exception a)
-tryMost action = do r <- try action; filter r
-  where
-   filter (Left e@(Exception.DynException d))
-	    | Just ghc_ex <- fromDynamic d
-		= case ghc_ex of
-		    Interrupted -> Exception.throw e
-		    Panic _     -> Exception.throw e
-		    _other      -> return (Left e)
-   filter other 
-     = return other
-#else
 -- XXX I'm not entirely sure if this is catching what we really want to catch
 tryMost :: IO a -> IO (Either SomeException a)
 tryMost action = do r <- try action
                     case r of
-                        Left se@(SomeException e) ->
-                            case cast e of
+                        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)
                                 Nothing ->
-                                    case cast e of
+                                    case fromException se of
                                         -- All IOExceptions are returned
                                         Just (_ :: IOException) ->
                                             return (Left se)
                                         -- Anything else is rethrown
                                         Nothing -> throwIO se
                         Right v -> return (Right v)
-#endif
-
--- | tryUser is like try, but catches only UserErrors.
--- These are the ones that are thrown by the TcRn monad 
--- to signal an error in the program being compiled
-#if __GLASGOW_HASKELL__ < 609
-tryUser :: IO a -> IO (Either Exception.Exception a)
-tryUser action = tryJust tc_errors action
-  where 
-	tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
-	tc_errors _other = Nothing
-#else
-tryUser :: IO a -> IO (Either IOException a)
-tryUser io =
-    do ei <- try io
-       case ei of
-           Right v -> return (Right v)
-           Left se@(SomeException ex) ->
-                case cast ex of
-                   Just ioe
-                    | isUserError ioe ->
-                       return (Left ioe)
-                   _ -> throw se
-#endif
 \end{code}
 
 Standard signal handlers for catching ^C, which just throw an
@@ -241,22 +181,27 @@ installSignalHandlers.
 \begin{code}
 installSignalHandlers :: IO ()
 installSignalHandlers = do
+  main_thread <- myThreadId
+  modifyMVar_ interruptTargetThread (return . (main_thread :))
+
   let
-#if __GLASGOW_HASKELL__ < 609
-      interrupt_exn = Exception.DynException (toDyn Interrupted)
-#else
-      interrupt_exn = (toException Interrupted)
-#endif
+      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
@@ -268,7 +213,7 @@ installSignalHandlers = do
       sig_handler Break    = interrupt
       sig_handler _        = return ()
 
-  installHandler (Catch sig_handler)
+  _ <- installHandler (Catch sig_handler)
   return ()
 #endif