[commit: ghc] master: Include a stack trace in the panic message, when GHC is compiled profiled. (f85c084)

[Simon Marlow]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/f85c084c0d6e8f7ac8b282220eb93c69e356b5e1

>---------------------------------------------------------------

commit f85c084c0d6e8f7ac8b282220eb93c69e356b5e1
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Wed Nov 30 11:32:23 2011 +0000

    Include a stack trace in the panic message, when GHC is compiled profiled.
    
    I tried this out on the panic we're currently getting for #3103:
    
    ghc-stage2: panic! (the 'impossible' happened)
      (GHC version 7.3.20111128 for x86_64-unknown-linux):
            tcIfaceGlobal (local): not found:
        base:GHC.Word.W#{d 6w}
        [(32R, Type constructor `base:GHC.Word.Word{tc 32R}'),
         (r6O, Identifier `base:GHC.Word.$fNumWord{v r6O}'),
         (r6P, Identifier `base:GHC.Word.$fEqWord{v r6P}'),
         (r6Q, Identifier `base:GHC.Word.$fNumWord1{v r6Q}'),
         (r6R, Identifier `base:GHC.Word.$fNumWord2{v r6R}'),
         (r6S, Data constructor `base:GHC.Word.W#{d r6S}'),
         (r6U, Identifier `base:GHC.Word.W#{v r6U}'),
         (r75, Identifier `base:GHC.Word.$fNumWord_$csignum{v r75}'),
         (r76, Identifier `base:GHC.Word.$fEqWord_$c/={v r76}'),
         (r77, Identifier `base:GHC.Word.$fEqWord_$c=={v r77}')]
    { Main.main
       GHC.defaultErrorHandler
        GHC.runGhc
         GhcMonad.>>=
          GhcMonad.>>=.\
           Main.main'
            Main.doMake
             GhcMake.load
              GhcMake.load2
               GhcMake.upsweep
                GhcMake.upsweep.upsweep'
                 GhcMake.reTypecheckLoop
                  GhcMake.typecheckLoop
                   GhcMake.typecheckLoop.\
                    TcRnMonad.initIfaceCheck
                     TcRnMonad.initTcRnIf
                      IOEnv.runIOEnv
                       IOEnv.thenM
                        IOEnv.thenM.\
                         TcIface.typecheckIface
                          TcIface.typecheckIface.\
                           LoadIface.loadDecls
                            LoadIface.loadDecl
                             TcIface.tcIfaceDecl
                              TcIface.tc_iface_decl
                               TcIface.tcIdInfo
                                MonadUtils.foldlM
                                 TcIface.tcIdInfo.tcPrag
                                  TcIface.tcUnfolding
                                   TcIface.tcPragExpr
                                    TcIface.tcIfaceExpr
                                     TcIface.tcIfaceAlt
                                      TcIface.tcIfaceDataCon }

>---------------------------------------------------------------

 compiler/utils/Panic.lhs |   14 +++++++++++++-
 1 files changed, 13 insertions(+), 1 deletions(-)

diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs
index 4cf2695..cc3603b 100644
--- a/compiler/utils/Panic.lhs
+++ b/compiler/utils/Panic.lhs
@@ -35,7 +35,7 @@ import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_,
                             myThreadId )
 import Data.Dynamic
 import Debug.Trace	  ( trace )
-import System.IO.Unsafe	  ( unsafePerformIO )
+import System.IO.Unsafe
 import System.Exit
 import System.Environment
 
@@ -47,6 +47,9 @@ import System.Posix.Signals
 import GHC.ConsoleHandler
 #endif
 
+#if __GLASGOW_HASKELL__ >= 703
+import GHC.Stack
+#endif
 
 -- | GHC's own exception type 
 --   error messages all take the form:
@@ -160,7 +163,16 @@ handleGhcException = ghandle
 
 -- | Panics and asserts.
 panic, sorry, pgmError :: String -> a
+#if __GLASGOW_HASKELL__ >= 703
+panic    x = unsafeDupablePerformIO $ do
+   stack <- ccsToStrings =<< getCurrentCCS x
+   if null stack
+      then throwGhcException (Panic x)
+      else throwGhcException (Panic (x ++ '\n' : renderStack stack))
+#else
 panic    x = throwGhcException (Panic x)
+#endif
+
 sorry    x = throwGhcException (Sorry x)
 pgmError x = throwGhcException (ProgramError x)