summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/UniqSupply.hs2
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/iface/BinFingerprint.hs2
-rw-r--r--compiler/utils/Binary.hs2
-rw-r--r--compiler/utils/FastString.hs2
-rw-r--r--compiler/utils/Panic.hs116
-rw-r--r--compiler/utils/PlainPanic.hs138
-rw-r--r--compiler/utils/Pretty.hs5
-rw-r--r--compiler/utils/StringBuffer.hs2
-rw-r--r--compiler/utils/Util.hs2
-rw-r--r--includes/CodeGen.Platform.hs2
11 files changed, 178 insertions, 96 deletions
diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs
index 348c170d7f..8780a52208 100644
--- a/compiler/basicTypes/UniqSupply.hs
+++ b/compiler/basicTypes/UniqSupply.hs
@@ -37,7 +37,7 @@ module UniqSupply (
import GhcPrelude
import Unique
-import Panic (panic)
+import PlainPanic (panic)
import GHC.IO
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index e3e3df0b3f..38ef67d495 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -558,6 +558,7 @@ Library
Outputable
Pair
Panic
+ PlainPanic
PprColour
Pretty
State
diff --git a/compiler/iface/BinFingerprint.hs b/compiler/iface/BinFingerprint.hs
index 913ece0f27..1eef4d67b4 100644
--- a/compiler/iface/BinFingerprint.hs
+++ b/compiler/iface/BinFingerprint.hs
@@ -15,7 +15,7 @@ import GhcPrelude
import Fingerprint
import Binary
import Name
-import Panic
+import PlainPanic
import Util
fingerprintBinMem :: BinHandle -> IO Fingerprint
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index e6dfa3da2c..035b65ff23 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -64,7 +64,7 @@ import GhcPrelude
import {-# SOURCE #-} Name (Name)
import FastString
-import Panic
+import PlainPanic
import UniqFM
import FastMutInt
import Fingerprint
diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs
index 4f16624537..0db61ec93f 100644
--- a/compiler/utils/FastString.hs
+++ b/compiler/utils/FastString.hs
@@ -101,7 +101,7 @@ import GhcPrelude as Prelude
import Encoding
import FastFunctions
-import Panic
+import PlainPanic
import Util
import Control.Concurrent.MVar
diff --git a/compiler/utils/Panic.hs b/compiler/utils/Panic.hs
index df6612bdda..16f493826c 100644
--- a/compiler/utils/Panic.hs
+++ b/compiler/utils/Panic.hs
@@ -14,7 +14,7 @@ module Panic (
GhcException(..), showGhcException,
throwGhcException, throwGhcExceptionIO,
handleGhcException,
- progName,
+ PlainPanic.progName,
pgmError,
panic, sorry, assertPanic, trace,
@@ -27,20 +27,19 @@ module Panic (
withSignalHandlers,
) where
-#include "HsVersions.h"
import GhcPrelude
import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe)
+import PlainPanic
-import Config
import Exception
import Control.Monad.IO.Class
import Control.Concurrent
+import Data.Typeable ( cast )
import Debug.Trace ( trace )
import System.IO.Unsafe
-import System.Environment
#if !defined(mingw32_HOST_OS)
import System.Posix.Signals as S
@@ -50,7 +49,6 @@ import System.Posix.Signals as S
import GHC.ConsoleHandler as S
#endif
-import GHC.Stack
import System.Mem.Weak ( deRefWeak )
-- | GHC's own exception type
@@ -91,25 +89,25 @@ data GhcException
| ProgramError String
| PprProgramError String SDoc
-instance Exception GhcException
+instance Exception GhcException where
+ fromException (SomeException e)
+ | Just ge <- cast e = Just ge
+ | Just pge <- cast e = Just $
+ case pge of
+ PlainSignal n -> Signal n
+ PlainUsageError str -> UsageError str
+ PlainCmdLineError str -> CmdLineError str
+ PlainPanic str -> Panic str
+ PlainSorry str -> Sorry str
+ PlainInstallationError str -> InstallationError str
+ PlainProgramError str -> ProgramError str
+ | otherwise = Nothing
instance Show GhcException where
showsPrec _ e@(ProgramError _) = showGhcException e
showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e
showsPrec _ e = showString progName . showString ": " . showGhcException e
-
--- | The name of this GHC.
-progName :: String
-progName = unsafePerformIO (getProgName)
-{-# NOINLINE progName #-}
-
-
--- | Short usage information to display when we are given the wrong cmd line arguments.
-short_usage :: String
-short_usage = "Usage: For basic information, try the `--help' option."
-
-
-- | Show an exception as a string.
showException :: Exception e => e -> String
showException = show
@@ -134,42 +132,21 @@ safeShowException e = do
-- If the error message to be printed includes a pretty-printer document
-- which forces one of these fields this call may bottom.
showGhcException :: GhcException -> ShowS
-showGhcException exception
- = case exception of
- UsageError str
- -> showString str . showChar '\n' . showString short_usage
-
- CmdLineError str -> showString str
- PprProgramError str sdoc ->
- showString str . showString "\n\n" .
- showString (showSDocUnsafe sdoc)
- ProgramError str -> showString str
- InstallationError str -> showString str
- Signal n -> showString "signal: " . shows n
-
- PprPanic s sdoc ->
- panicMsg $ showString s . showString "\n\n"
- . showString (showSDocUnsafe sdoc)
- Panic s -> panicMsg (showString s)
-
- PprSorry s sdoc ->
- sorryMsg $ showString s . showString "\n\n"
- . showString (showSDocUnsafe sdoc)
- Sorry s -> sorryMsg (showString s)
- where
- sorryMsg :: ShowS -> ShowS
- sorryMsg s =
- showString "sorry! (unimplemented feature or known bug)\n"
- . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")
- . s . showString "\n"
-
- panicMsg :: ShowS -> ShowS
- panicMsg s =
- showString "panic! (the 'impossible' happened)\n"
- . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")
- . s . showString "\n\n"
- . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
-
+showGhcException = showPlainGhcException . \case
+ Signal n -> PlainSignal n
+ UsageError str -> PlainUsageError str
+ CmdLineError str -> PlainCmdLineError str
+ Panic str -> PlainPanic str
+ Sorry str -> PlainSorry str
+ InstallationError str -> PlainInstallationError str
+ ProgramError str -> PlainProgramError str
+
+ PprPanic str sdoc -> PlainPanic $
+ concat [str, "\n\n", showSDocUnsafe sdoc]
+ PprSorry str sdoc -> PlainProgramError $
+ concat [str, "\n\n", showSDocUnsafe sdoc]
+ PprProgramError str sdoc -> PlainProgramError $
+ concat [str, "\n\n", showSDocUnsafe sdoc]
throwGhcException :: GhcException -> a
throwGhcException = Exception.throw
@@ -180,42 +157,11 @@ throwGhcExceptionIO = Exception.throwIO
handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
handleGhcException = ghandle
-
--- | Panics and asserts.
-panic, sorry, pgmError :: String -> a
-panic x = unsafeDupablePerformIO $ do
- stack <- ccsToStrings =<< getCurrentCCS x
- if null stack
- then throwGhcException (Panic x)
- else throwGhcException (Panic (x ++ '\n' : renderStack stack))
-
-sorry x = throwGhcException (Sorry x)
-pgmError x = throwGhcException (ProgramError x)
-
panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a
panicDoc x doc = throwGhcException (PprPanic x doc)
sorryDoc x doc = throwGhcException (PprSorry x doc)
pgmErrorDoc x doc = throwGhcException (PprProgramError x doc)
-cmdLineError :: String -> a
-cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO
-
-cmdLineErrorIO :: String -> IO a
-cmdLineErrorIO x = do
- stack <- ccsToStrings =<< getCurrentCCS x
- if null stack
- then throwGhcException (CmdLineError x)
- else throwGhcException (CmdLineError (x ++ '\n' : renderStack stack))
-
-
-
--- | Throw a failed assertion exception for a given filename and line number.
-assertPanic :: String -> Int -> a
-assertPanic file line =
- Exception.throw (Exception.AssertionFailed
- ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
-
-
-- | Like try, but pass through UserInterrupt and Panic exceptions.
-- Used when we want soft failures when reading interface files, for example.
-- TODO: I'm not entirely sure if this is catching what we really want to catch
diff --git a/compiler/utils/PlainPanic.hs b/compiler/utils/PlainPanic.hs
new file mode 100644
index 0000000000..0892ebff7d
--- /dev/null
+++ b/compiler/utils/PlainPanic.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-}
+
+-- | Defines a simple exception type and utilities to throw it. The
+-- 'PlainGhcException' type is a subset of the 'Panic.GhcException'
+-- type. It omits the exception constructors that involve
+-- pretty-printing via 'Outputable.SDoc'.
+--
+-- There are two reasons for this:
+--
+-- 1. To avoid import cycles / use of boot files. "Outputable" has
+-- many transitive dependencies. To throw exceptions from these
+-- modules, the functions here can be used without introducing import
+-- cycles.
+--
+-- 2. To reduce the number of modules that need to be compiled to
+-- object code when loading GHC into GHCi. See #13101
+module PlainPanic
+ ( PlainGhcException(..)
+ , showPlainGhcException
+
+ , panic, sorry, pgmError
+ , cmdLineError, cmdLineErrorIO
+ , assertPanic
+
+ , progName
+ ) where
+
+#include "HsVersions.h"
+
+import Config
+import Exception
+import GHC.Stack
+import GhcPrelude
+import System.Environment
+import System.IO.Unsafe
+
+-- | This type is very similar to 'Panic.GhcException', but it omits
+-- the constructors that involve pretty-printing via
+-- 'Outputable.SDoc'. Due to the implementation of 'fromException'
+-- for 'Panic.GhcException', this type can be caught as a
+-- 'Panic.GhcException'.
+--
+-- Note that this should only be used for throwing exceptions, not for
+-- catching, as 'Panic.GhcException' will not be converted to this
+-- type when catching.
+data PlainGhcException
+ -- | Some other fatal signal (SIGHUP,SIGTERM)
+ = PlainSignal Int
+
+ -- | Prints the short usage msg after the error
+ | PlainUsageError String
+
+ -- | A problem with the command line arguments, but don't print usage.
+ | PlainCmdLineError String
+
+ -- | The 'impossible' happened.
+ | PlainPanic String
+
+ -- | The user tickled something that's known not to work yet,
+ -- but we're not counting it as a bug.
+ | PlainSorry String
+
+ -- | An installation problem.
+ | PlainInstallationError String
+
+ -- | An error in the user's code, probably.
+ | PlainProgramError String
+
+instance Exception PlainGhcException
+
+instance Show PlainGhcException where
+ showsPrec _ e@(PlainProgramError _) = showPlainGhcException e
+ showsPrec _ e@(PlainCmdLineError _) = showString "<command line>: " . showPlainGhcException e
+ showsPrec _ e = showString progName . showString ": " . showPlainGhcException e
+
+-- | The name of this GHC.
+progName :: String
+progName = unsafePerformIO (getProgName)
+{-# NOINLINE progName #-}
+
+-- | Short usage information to display when we are given the wrong cmd line arguments.
+short_usage :: String
+short_usage = "Usage: For basic information, try the `--help' option."
+
+-- | Append a description of the given exception to this string.
+showPlainGhcException :: PlainGhcException -> ShowS
+showPlainGhcException =
+ \case
+ PlainSignal n -> showString "signal: " . shows n
+ PlainUsageError str -> showString str . showChar '\n' . showString short_usage
+ PlainCmdLineError str -> showString str
+ PlainPanic s -> panicMsg (showString s)
+ PlainSorry s -> sorryMsg (showString s)
+ PlainInstallationError str -> showString str
+ PlainProgramError str -> showString str
+ where
+ sorryMsg :: ShowS -> ShowS
+ sorryMsg s =
+ showString "sorry! (unimplemented feature or known bug)\n"
+ . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")
+ . s . showString "\n"
+
+ panicMsg :: ShowS -> ShowS
+ panicMsg s =
+ showString "panic! (the 'impossible' happened)\n"
+ . showString (" (GHC version " ++ cProjectVersion ++ ":\n\t")
+ . s . showString "\n\n"
+ . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n"
+
+throwPlainGhcException :: PlainGhcException -> a
+throwPlainGhcException = Exception.throw
+
+-- | Panics and asserts.
+panic, sorry, pgmError :: String -> a
+panic x = unsafeDupablePerformIO $ do
+ stack <- ccsToStrings =<< getCurrentCCS x
+ if null stack
+ then throwPlainGhcException (PlainPanic x)
+ else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack))
+
+sorry x = throwPlainGhcException (PlainSorry x)
+pgmError x = throwPlainGhcException (PlainProgramError x)
+
+cmdLineError :: String -> a
+cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO
+
+cmdLineErrorIO :: String -> IO a
+cmdLineErrorIO x = do
+ stack <- ccsToStrings =<< getCurrentCCS x
+ if null stack
+ then throwPlainGhcException (PlainCmdLineError x)
+ else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack))
+
+-- | Throw a failed assertion exception for a given filename and line number.
+assertPanic :: String -> Int -> a
+assertPanic file line =
+ Exception.throw (Exception.AssertionFailed
+ ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs
index 66518f95b6..5adfdd7699 100644
--- a/compiler/utils/Pretty.hs
+++ b/compiler/utils/Pretty.hs
@@ -115,7 +115,7 @@ import GhcPrelude hiding (error)
import BufWrite
import FastString
-import Panic
+import PlainPanic
import System.IO
import Numeric (showHex)
@@ -123,9 +123,6 @@ import Numeric (showHex)
import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) )
import GHC.Ptr ( Ptr(..) )
--- Don't import Util( assertPanic ) because it makes a loop in the module structure
-
-
-- ---------------------------------------------------------------------------
-- The Doc calculus
diff --git a/compiler/utils/StringBuffer.hs b/compiler/utils/StringBuffer.hs
index 64578bffde..98b8c19340 100644
--- a/compiler/utils/StringBuffer.hs
+++ b/compiler/utils/StringBuffer.hs
@@ -50,7 +50,7 @@ import GhcPrelude
import Encoding
import FastString
import FastFunctions
-import Outputable
+import PlainPanic
import Util
import Data.Maybe
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index c07b87f547..4b8c47a2cf 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -134,7 +134,7 @@ module Util (
import GhcPrelude
import Exception
-import Panic
+import PlainPanic
import Data.Data
import Data.IORef ( IORef, newIORef, atomicModifyIORef' )
diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs
index 867dd14fb0..27a9324438 100644
--- a/includes/CodeGen.Platform.hs
+++ b/includes/CodeGen.Platform.hs
@@ -2,7 +2,7 @@
import CmmExpr
#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \
|| defined(MACHREGS_sparc) || defined(MACHREGS_powerpc))
-import Panic
+import PlainPanic
#endif
import Reg
View Lorry Controller Status