Avoid unsafePerformIO for getProgName

getProgName was used to append the name of the program (e.g. "ghc") to
printed error messages in the Show instance of GhcException. It doesn't
belong here as GHCi and GHC API users may want to override this behavior
by setting a different error handler. So we now call it in the
defaultErrorHandler instead.

7 files changed, 20 insertions, 27 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index ea1293f2a8..b7dd7dfd35 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -420,7 +420,7 @@ import Control.Monad.Catch as MC
 
 import GHC.Data.Maybe
 import System.IO.Error  ( isDoesNotExistError )
-import System.Environment ( getEnv )
+import System.Environment ( getEnv, getProgName )
 import System.Directory
 import Data.List (isPrefixOf)
 
@@ -465,9 +465,13 @@ defaultErrorHandler fm (FlushOut flushOut) inner =
             (\ge -> liftIO $ do
                 flushOut
                 case ge of
-                     Signal _ -> exitWith (ExitFailure 1)
-                     _ -> do fm (show ge)
-                             exitWith (ExitFailure 1)
+                  Signal _       -> return ()
+                  ProgramError _ -> fm (show ge)
+                  CmdLineError _ -> fm ("<command line>: " ++ show ge)
+                  _              -> do
+                                    progName <- getProgName
+                                    fm (progName ++ ": " ++ show ge)
+                exitWith (ExitFailure 1)
             ) $
   inner
 
diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs
index 497ea65003..04e94b81d4 100644
--- a/compiler/GHC/Utils/Panic.hs
+++ b/compiler/GHC/Utils/Panic.hs
@@ -19,7 +19,6 @@ module GHC.Utils.Panic
    , throwGhcExceptionIO
    , handleGhcException
 
-   , GHC.Utils.Panic.Plain.progName
    , pgmError
    , panic
    , pprPanic
@@ -124,9 +123,7 @@ instance Exception GhcException where
     | otherwise = Nothing
 
 instance Show GhcException where
-  showsPrec _ e@(ProgramError _) = showGhcExceptionUnsafe e
-  showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcExceptionUnsafe e
-  showsPrec _ e = showString progName . showString ": " . showGhcExceptionUnsafe e
+  showsPrec _ e = showGhcExceptionUnsafe e
 
 -- | Show an exception as a string.
 showException :: Exception e => e -> String
diff --git a/compiler/GHC/Utils/Panic/Plain.hs b/compiler/GHC/Utils/Panic/Plain.hs
index 709bbaf152..355c1c039d 100644
--- a/compiler/GHC/Utils/Panic/Plain.hs
+++ b/compiler/GHC/Utils/Panic/Plain.hs
@@ -22,8 +22,6 @@ module GHC.Utils.Panic.Plain
   , cmdLineError, cmdLineErrorIO
   , assertPanic
   , assert, assertM, massert
-
-  , progName
   ) where
 
 import GHC.Settings.Config
@@ -31,7 +29,6 @@ import GHC.Utils.Constants
 import GHC.Utils.Exception as Exception
 import GHC.Stack
 import GHC.Prelude
-import System.Environment
 import System.IO.Unsafe
 
 -- | This type is very similar to 'GHC.Utils.Panic.GhcException', but it omits
@@ -69,14 +66,7 @@ data PlainGhcException
 instance Exception PlainGhcException
 
 instance Show PlainGhcException where
-  showsPrec _ e@(PlainProgramError _) = showPlainGhcException e
-  showsPrec _ e@(PlainCmdLineError _) = showString "<command line>: " . showPlainGhcException e
-  showsPrec _ e = showString progName . showString ": " . showPlainGhcException e
-
--- | The name of this GHC.
-progName :: String
-progName = unsafePerformIO (getProgName)
-{-# NOINLINE progName #-}
+  showsPrec _ e = showPlainGhcException e
 
 -- | Short usage information to display when we are given the wrong cmd line arguments.
 short_usage :: String
diff --git a/ghc/Main.hs b/ghc/Main.hs
index bda5cd9ef9..ad975d1840 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -762,11 +762,13 @@ showUsage ghci dflags = do
   let usage_path = if ghci then ghciUsagePath dflags
                            else ghcUsagePath dflags
   usage <- readFile usage_path
-  dump usage
+  progName <- getProgName
+  dump progName usage
   where
-     dump ""          = return ()
-     dump ('$':'$':s) = putStr progName >> dump s
-     dump (c:s)       = putChar c >> dump s
+    dump progName xs = case xs of
+      ""        -> return ()
+      '$':'$':s -> putStr progName >> dump progName s
+      c:s       -> putChar c >> dump progName s
 
 dumpFinalStats :: Logger -> IO ()
 dumpFinalStats logger = do
diff --git a/testsuite/tests/safeHaskell/ghci/p5.stderr b/testsuite/tests/safeHaskell/ghci/p5.stderr
index 7e70988612..6579b9f765 100644
--- a/testsuite/tests/safeHaskell/ghci/p5.stderr
+++ b/testsuite/tests/safeHaskell/ghci/p5.stderr
@@ -1,7 +1,7 @@
 Some flags have not been recognized: -XNoSafe
-ghc-stage2: <no location info>: Incompatible Safe Haskell flags! (Safe, Trustworthy)
+<no location info>: Incompatible Safe Haskell flags! (Safe, Trustworthy)
 Usage: For basic information, try the `--help' option.
 Some flags have not been recognized: -XNoTrustworthy
-ghc-stage2: <no location info>: Incompatible Safe Haskell flags! (Safe, Unsafe)
+<no location info>: Incompatible Safe Haskell flags! (Safe, Unsafe)
 Usage: For basic information, try the `--help' option.
 Some flags have not been recognized: -XNoUnsafe
diff --git a/testsuite/tests/safeHaskell/ghci/p7.stderr b/testsuite/tests/safeHaskell/ghci/p7.stderr
index 674794fdac..99237ce045 100644
--- a/testsuite/tests/safeHaskell/ghci/p7.stderr
+++ b/testsuite/tests/safeHaskell/ghci/p7.stderr
@@ -1,2 +1,2 @@
-ghc-stage2: A.hs:1:14-24: Incompatible Safe Haskell flags! (Safe, Trustworthy)
+A.hs:1:14-24: Incompatible Safe Haskell flags! (Safe, Trustworthy)
 Usage: For basic information, try the `--help' option.
diff --git a/testsuite/tests/safeHaskell/ghci/p8.stderr b/testsuite/tests/safeHaskell/ghci/p8.stderr
index 8280f4a6b0..e82c75a59c 100644
--- a/testsuite/tests/safeHaskell/ghci/p8.stderr
+++ b/testsuite/tests/safeHaskell/ghci/p8.stderr
@@ -1,2 +1,2 @@
-ghc-stage2: B.hs:1:14-19: Incompatible Safe Haskell flags! (Safe, Unsafe)
+B.hs:1:14-19: Incompatible Safe Haskell flags! (Safe, Unsafe)
 Usage: For basic information, try the `--help' option.