From d9dfbde30aa11afc87f25b73dc2d154a46ca24d4 Mon Sep 17 00:00:00 2001
From: Michael Sloan <mgsloan@gmail.com>
Date: Thu, 14 Mar 2019 15:47:44 -0700
Subject: [PATCH] Add PlainPanic for throwing exceptions without depending on
pprint
This commit splits out a subset of GhcException which do not depend on
pretty printing (SDoc), as a new datatype called
PlainGhcException. These exceptions can be caught as GhcException,
because 'fromException' will convert them.
The motivation for this change is that that the Panic module
transitively depends on many modules, primarily due to pretty printing
code. It's on the order of about 130 modules. This large set of
dependencies has a few implications:
1. To avoid cycles / use of boot files, these dependencies cannot
throw GhcException.
2. There are some utility modules that use UnboxedTuples and also use
`panic`. This means that when loading GHC into GHCi, about 130
additional modules would need to be compiled instead of
interpreted. Splitting the non-pprint exception throwing into a new
module resolves this issue. See #13101
---
compiler/basicTypes/UniqSupply.hs | 2 +-
compiler/ghc.cabal.in | 1 +
compiler/iface/BinFingerprint.hs | 2 +-
compiler/utils/Binary.hs | 2 +-
compiler/utils/FastString.hs | 2 +-
compiler/utils/Panic.hs | 116 +++++++------------------
compiler/utils/PlainPanic.hs | 138 ++++++++++++++++++++++++++++++
compiler/utils/Pretty.hs | 5 +-
compiler/utils/StringBuffer.hs | 2 +-
compiler/utils/Util.hs | 2 +-
includes/CodeGen.Platform.hs | 2 +-
11 files changed, 178 insertions(+), 96 deletions(-)
create mode 100644 compiler/utils/PlainPanic.hs
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
--
GitLab