[Git][ghc/ghc][wip/andreask/callstack-prelude] Make use of DebugCallStack for plain panic.

[Andreas Klebinger]

Andreas Klebinger pushed to branch wip/andreask/callstack-prelude at Glasgow Haskell Compiler / GHC


Commits:
85f6487f by Andreas Klebinger at 2020-05-26T14:30:57+02:00
Make use of DebugCallStack for plain panic.

Also move HasDebugCallStack into GHC.Prelude.

This allows it to be used without indirectly depending on
the Outputable module.

- - - - -


4 changed files:

- compiler/GHC/Prelude.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Utils/Misc.hs
- compiler/GHC/Utils/Panic/Plain.hs


Changes:

=====================================
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?]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -109,7 +109,6 @@ import GHC.Data.List.SetOps
 import GHC.Utils.Error
 import GHC.Data.Maybe( MaybeErr(..), orElse )
 import qualified GHC.LanguageExtensions as LangExt
-import GHC.Utils.Misc ( HasDebugCallStack )
 
 import Data.IORef
 import Data.List (intercalate)


=====================================
compiler/GHC/Utils/Misc.hs
=====================================
@@ -1440,13 +1440,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


=====================================
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))



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85f6487ff04e857acd333d176f33e9c26e0256cd

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85f6487ff04e857acd333d176f33e9c26e0256cd
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/20200526/78b72725/attachment-0001.html>