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

2 files changed, 34 insertions, 20 deletions

diff --git a/compiler/utils/Outputable.hs-boot b/compiler/utils/Outputable.hs-boot
index 1c15a6982a..e5e88953cc 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 f1ccb7b5a5..b19c770718 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