diff options
| -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)) |