Commit d9dfbde3 authored by Michael Sloan's avatar Michael Sloan Committed by Matthew Pickering

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
parent c931f256
Pipeline #6049 passed with stages
in 331 minutes and 23 seconds
......@@ -37,7 +37,7 @@ module UniqSupply (
import GhcPrelude
import Unique
import Panic (panic)
import PlainPanic (panic)
import GHC.IO
......
......@@ -558,6 +558,7 @@ Library
Outputable
Pair
Panic
PlainPanic
PprColour
Pretty
State
......
......@@ -15,7 +15,7 @@ import GhcPrelude
import Fingerprint
import Binary
import Name
import Panic
import PlainPanic
import Util
fingerprintBinMem :: BinHandle -> IO Fingerprint
......
......@@ -64,7 +64,7 @@ import GhcPrelude
import {-# SOURCE #-} Name (Name)
import FastString
import Panic
import PlainPanic
import UniqFM
import FastMutInt
import Fingerprint
......
......@@ -101,7 +101,7 @@ import GhcPrelude as Prelude
import Encoding
import FastFunctions
import Panic
import PlainPanic
import Util
import Control.Concurrent.MVar
......
......@@ -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
......
{-# 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))
......@@ -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
......
......@@ -50,7 +50,7 @@ import GhcPrelude
import Encoding
import FastString
import FastFunctions
import Outputable
import PlainPanic
import Util
import Data.Maybe
......
......@@ -134,7 +134,7 @@ module Util (
import GhcPrelude
import Exception
import Panic
import PlainPanic
import Data.Data
import Data.IORef ( IORef, newIORef, atomicModifyIORef' )
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment