diff options
author | Andreas Klebinger <klebinger.andreas@gmx.at> | 2020-05-26 13:12:52 +0200 |
---|---|---|
committer | Andreas Klebinger <klebinger.andreas@gmx.at> | 2021-03-10 07:45:42 -0500 |
commit | 09aaaae658ef79e9c5fec21b5a3121d2b809ba08 (patch) | |
tree | a331b2b076e0cc588bb308a2f8d28017d0dcedb5 | |
parent | df8e8ba267ffd7b8be0702bd64b8c39532359461 (diff) | |
download | haskell-09aaaae658ef79e9c5fec21b5a3121d2b809ba08.tar.gz |
Make use of DebugCallStack for plain panic.wip/andreask/callstack-prelude
Also move HasDebugCallStack into GHC.Prelude.
This allows it to be used without indirectly depending on
the Outputable module.
-rw-r--r-- | compiler/GHC/Prelude.hs | 18 | ||||
-rw-r--r-- | compiler/GHC/Utils/Misc.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Utils/Panic/Plain.hs | 14 |
3 files changed, 23 insertions, 16 deletions
diff --git a/compiler/GHC/Prelude.hs b/compiler/GHC/Prelude.hs index 95c2d4b190..eb8bc31cef 100644 --- a/compiler/GHC/Prelude.hs +++ b/compiler/GHC/Prelude.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} - +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} -- | Custom GHC "Prelude" -- -- This module serves as a replacement for the "Prelude" module @@ -10,7 +11,7 @@ -- * Is compiled with -XNoImplicitPrelude -- * Explicitly imports GHC.Prelude -module GHC.Prelude (module X) where +module GHC.Prelude (module X, HasDebugCallStack) where -- We export the 'Semigroup' class but w/o the (<>) operator to avoid -- clashing with the (Outputable.<>) operator which is heavily used @@ -19,6 +20,19 @@ module GHC.Prelude (module X) where import Prelude as X hiding ((<>)) import Data.Foldable as X (foldl') +import GHC.Exts (Constraint) +#if defined(DEBUG) +import GHC.Stack (HasCallStack) +#endif +-- We define + +-- | A call stack constraint, but only when 'isDebugOn'. +#if defined(DEBUG) +type HasDebugCallStack = HasCallStack +#else +type HasDebugCallStack = (() :: Constraint) +#endif + {- Note [Why do we import Prelude here?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index f7168190e4..bfe263a083 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -1555,13 +1555,6 @@ mulHi a b = fromIntegral (r `shiftR` 32) where r :: Int64 r = fromIntegral a * fromIntegral b --- | A call stack constraint, but only when 'isDebugOn'. -#if defined(DEBUG) -type HasDebugCallStack = HasCallStack -#else -type HasDebugCallStack = (() :: Constraint) -#endif - data OverridingBool = Auto | Always diff --git a/compiler/GHC/Utils/Panic/Plain.hs b/compiler/GHC/Utils/Panic/Plain.hs index 8e54f81cde..d898fa9df7 100644 --- a/compiler/GHC/Utils/Panic/Plain.hs +++ b/compiler/GHC/Utils/Panic/Plain.hs @@ -111,15 +111,15 @@ throwPlainGhcException :: PlainGhcException -> a throwPlainGhcException = Exception.throw -- | Panics and asserts. -panic, sorry, pgmError :: String -> a +panic, sorry, pgmError :: HasCallStack => String -> a panic x = unsafeDupablePerformIO $ do stack <- ccsToStrings =<< getCurrentCCS x if null stack - then throwPlainGhcException (PlainPanic x) - else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack)) + then throwPlainGhcException (PlainPanic ((prettyCallStack callStack) ++ "\n" ++ x)) + else throwPlainGhcException (PlainPanic ((prettyCallStack callStack) ++ "\n" ++ x ++ '\n' : renderStack stack)) -sorry x = throwPlainGhcException (PlainSorry x) -pgmError x = throwPlainGhcException (PlainProgramError x) +sorry x = throwPlainGhcException (PlainSorry $ (prettyCallStack callStack) ++ "\n" ++ x) +pgmError x = throwPlainGhcException (PlainProgramError $ (prettyCallStack callStack) ++ "\n" ++x) cmdLineError :: String -> a cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO @@ -132,7 +132,7 @@ cmdLineErrorIO x = do else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack)) -- | Throw a failed assertion exception for a given filename and line number. -assertPanic :: String -> Int -> a +assertPanic :: HasCallStack => String -> Int -> a assertPanic file line = Exception.throw (Exception.AssertionFailed - ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) + ((prettyCallStack callStack) ++ "\nASSERT failed! file " ++ file ++ ", line " ++ show line)) |