[Git][ghc/ghc][master] Add PlainPanic for throwing exceptions without depending on pprint
Marge Bot
gitlab at gitlab.haskell.org
Sat May 25 21:51:28 UTC 2019
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
d9dfbde3 by Michael Sloan at 2019-05-24T15:55:07Z
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
- - - - -
11 changed files:
- compiler/basicTypes/UniqSupply.hs
- compiler/ghc.cabal.in
- compiler/iface/BinFingerprint.hs
- compiler/utils/Binary.hs
- compiler/utils/FastString.hs
- compiler/utils/Panic.hs
- + compiler/utils/PlainPanic.hs
- compiler/utils/Pretty.hs
- compiler/utils/StringBuffer.hs
- compiler/utils/Util.hs
- includes/CodeGen.Platform.hs
Changes:
=====================================
compiler/basicTypes/UniqSupply.hs
=====================================
@@ -37,7 +37,7 @@ module UniqSupply (
import GhcPrelude
import Unique
-import Panic (panic)
+import PlainPanic (panic)
import GHC.IO
=====================================
compiler/ghc.cabal.in
=====================================
@@ -558,6 +558,7 @@ Library
Outputable
Pair
Panic
+ PlainPanic
PprColour
Pretty
State
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
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))
=====================================
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
=====================================
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
=====================================
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' )
=====================================
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 it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/d9dfbde30aa11afc87f25b73dc2d154a46ca24d4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/d9dfbde30aa11afc87f25b73dc2d154a46ca24d4
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190525/5c69641f/attachment-0001.html>
More information about the ghc-commits
mailing list