\begin{code}
module Panic
(
- GhcException(..), ghcError, progName,
+ GhcException(..), showGhcException, ghcError, progName,
pgmError,
+
panic, panic#, assertPanic, trace,
- showException, showGhcException, tryMost,
- installSignalHandlers,
+
+ Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
+ catchJust, ioErrors, throwTo,
- catchJust, tryJust, ioErrors, throwTo,
+ installSignalHandlers, interruptTargetThread
) where
#include "HsVersions.h"
import EXCEPTION ( catchJust, tryJust, ioErrors )
#endif
-import CONCURRENT ( myThreadId )
+import CONCURRENT ( myThreadId, MVar, ThreadId, withMVar, newEmptyMVar )
import DYNAMIC
import qualified EXCEPTION as Exception
import TRACE ( trace )
import UNSAFE_IO ( unsafePerformIO )
+import IO ( isUserError )
import System
\end{code}
showGhcException (Interrupted)
= showString "interrupted"
showGhcException (Panic s)
- = showString ("panic! (the `impossible' happened, GHC version "
- ++ cProjectVersion ++ "):\n\t"
+ = showString ("panic! (the 'impossible' happened)\n"
+ ++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
++ s ++ "\n\n"
- ++ "Please report it as a compiler bug "
- ++ "to glasgow-haskell-bugs@haskell.org,\n"
- ++ "or http://sourceforge.net/projects/ghc/.\n\n")
+ ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n")
#if __GLASGOW_HASKELL__ < 603
myMkTyConApp = mkAppTy
panic x = Exception.throwDyn (Panic x)
pgmError x = Exception.throwDyn (ProgramError x)
--- #-versions because panic can't return an unboxed int, and that's
+-- #-versions because panic can't return an unboxed int, and that's
-- what TAG_ is with GHC at the moment. Ugh. (Simon)
-- No, man -- Too Beautiful! (Will)
-- files, for example.
tryMost :: IO a -> IO (Either Exception.Exception a)
-tryMost action = do r <- myTry action; filter r
+tryMost action = do r <- try action; filter r
where
filter (Left e@(Exception.DynException d))
| Just ghc_ex <- fromDynamic d
filter other
= return other
-#if __GLASGOW_HASKELL__ <= 408
-myTry = Exception.tryAllIO
-#else
-myTry = Exception.try
+-- | 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
+tryUser :: IO a -> IO (Either Exception.Exception a)
+tryUser action = tryJust tc_errors action
+ where
+#if __GLASGOW_HASKELL__ > 504 || __GLASGOW_HASKELL__ < 500
+ tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
+#elif __GLASGOW_HASKELL__ == 502
+ tc_errors e@(UserError _) = Just e
+#else
+ tc_errors e@(Exception.IOException ioe) | isUserError e = Just e
#endif
+ tc_errors _other = Nothing
\end{code}
Compatibility stuff:
\begin{code}
#if __GLASGOW_HASKELL__ <= 408
+try = Exception.tryAllIO
+#else
+try = Exception.try
+#endif
+
+#if __GLASGOW_HASKELL__ <= 408
catchJust = Exception.catchIO
tryJust = Exception.tryIO
ioErrors = Exception.justIoErrors
\end{code}
Standard signal handlers for catching ^C, which just throw an
-exception in the main thread. NOTE: must be called from the main
-thread.
+exception in the target thread. The current target thread is
+the thread at the head of the list in the MVar passed to
+installSignalHandlers.
\begin{code}
installSignalHandlers :: IO ()
installSignalHandlers = do
- main_thread <- myThreadId
let
interrupt_exn = Exception.DynException (toDyn Interrupted)
- interrupt = throwTo main_thread interrupt_exn
+
+ interrupt = do
+ withMVar interruptTargetThread $ \targets ->
+ case targets of
+ [] -> return ()
+ (thread:_) -> throwTo thread interrupt_exn
--
#if !defined(mingw32_HOST_OS)
installHandler sigQUIT (Catch interrupt) Nothing
#else
return () -- nothing
#endif
+
+{-# NOINLINE interruptTargetThread #-}
+interruptTargetThread :: MVar [ThreadId]
+interruptTargetThread = unsafePerformIO newEmptyMVar
\end{code}