[commit: ghc] wip/eventlog-heap-profile: Panic: Try outputting SDocs (e8d3567)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/eventlog-heap-profile
Link       : http://ghc.haskell.org/trac/ghc/changeset/e8d356773b56c1e56911b6359a368fe2f5d3ed1c/ghc

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

commit e8d356773b56c1e56911b6359a368fe2f5d3ed1c
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Sat Mar 26 00:42:27 2016 +0100

    Panic: Try outputting SDocs
    
    This works in conjunction with D2036 to allow useful debug output before
    DynFlags has been initializated.
    
    See #11755.
    
    Reviewers: austin
    
    Reviewed By: austin
    
    Subscribers: thomie, gridaphobe
    
    Differential Revision: https://phabricator.haskell.org/D2037
    
    GHC Trac Issues: #11755


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

e8d356773b56c1e56911b6359a368fe2f5d3ed1c
 compiler/utils/Outputable.hs-boot |  2 ++
 compiler/utils/Panic.hs           | 52 ++++++++++++++++++++++++---------------
 2 files changed, 34 insertions(+), 20 deletions(-)

diff --git a/compiler/utils/Outputable.hs-boot b/compiler/utils/Outputable.hs-boot
index 1c15a69..e5e8895 100644
--- a/compiler/utils/Outputable.hs-boot
+++ b/compiler/utils/Outputable.hs-boot
@@ -1,3 +1,5 @@
 module Outputable where
 
 data SDoc
+
+showSDocUnsafe :: SDoc -> String
diff --git a/compiler/utils/Panic.hs b/compiler/utils/Panic.hs
index f1ccb7b..b19c770 100644
--- a/compiler/utils/Panic.hs
+++ b/compiler/utils/Panic.hs
@@ -27,7 +27,7 @@ module Panic (
 ) where
 #include "HsVersions.h"
 
-import {-# SOURCE #-} Outputable (SDoc)
+import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe)
 
 import Config
 import Exception
@@ -125,35 +125,47 @@ safeShowException e = do
         forceList xs@(x : xt) = x `seq` forceList xt `seq` xs
 
 -- | Append a description of the given exception to this string.
-showGhcException :: GhcException -> String -> String
+--
+-- Note that this uses 'DynFlags.unsafeGlobalDynFlags', which may have some
+-- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called.
+-- 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  _  ->
-            showGhcException (ProgramError (str ++ "\n<<details unavailable>>"))
+        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 _ ->
-            showGhcException (Panic (s ++ "\n<<details unavailable>>"))
-        Panic s
-         -> showString $
-                "panic! (the 'impossible' happened)\n"
-                ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
-                ++ s ++ "\n\n"
-                ++ "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n"
-
-        PprSorry  s _ ->
-            showGhcException (Sorry (s ++ "\n<<details unavailable>>"))
-        Sorry s
-         -> showString $
-                "sorry! (unimplemented feature or known bug)\n"
-                 ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
-                 ++ s ++ "\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 ++ " for " ++ TargetPlatform_NAME ++ "):\n\t")
+      . s . showString "\n"
+
+    panicMsg :: ShowS -> ShowS
+    panicMsg s =
+        showString "panic! (the 'impossible' happened)\n"
+      . showString ("  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t")
+      . s . showString "\n\n"
+      . showString "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n"
 
 
 throwGhcException :: GhcException -> a