From f92acd8ed223ebbbf62fab930c6c346f5531d431 Mon Sep 17 00:00:00 2001
From: Thomas Miedema <thomasmiedema@gmail.com>
Date: Mon, 16 Mar 2015 18:36:59 +0100
Subject: [PATCH] Dont call unsafeGlobalDynFlags if it is not set
Parsing of static and mode flags happens before any session is started,
i.e., before the first call to 'GHC.withGhc'. Therefore, to report
errors for invalid usage of these two types of flags, we can not call
any function that needs DynFlags, as there are no DynFlags available yet
(unsafeGlobalDynFlags is not set either). So we always print "on the
commandline" as the location, which is true except for Api users, which
is probably ok.
When reporting errors for invalid usage of dynamic flags we /can/ make
use of DynFlags, and we do so explicitly in
DynFlags.parseDynamicFlagsFull.
Before, we called unsafeGlobalDynFlags when an invalid (combination of)
flag(s) was given on the commandline, resulting in panics (#9963). This
regression was introduced in 1d6124de.
Also rename showSDocSimple to showSDocUnsafe, to hopefully prevent this
from happening again.
Reviewed By: austin
Differential Revision: https://phabricator.haskell.org/D730
GHC Trac Issues: #9963
(cherry picked from commit 5166ee94e439375a4e6acb80f88ec6ee65476bbd)
---
compiler/basicTypes/SrcLoc.hs | 5 +----
compiler/main/CmdLineParser.hs | 24 +++++++++++++++++++++---
compiler/main/DynFlags.hs | 10 +++++++---
compiler/main/StaticFlags.hs | 7 +++++--
compiler/typecheck/TcGenDeriv.hs | 6 ++++--
compiler/utils/Outputable.hs | 8 +++++---
ghc/Main.hs | 9 ++++++---
testsuite/tests/driver/T9963.stderr | 2 ++
testsuite/tests/driver/all.T | 2 ++
9 files changed, 53 insertions(+), 20 deletions(-)
create mode 100644 testsuite/tests/driver/T9963.stderr
diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs
index 4f6cc1a17dcd..362a92599250 100644
--- a/compiler/basicTypes/SrcLoc.hs
+++ b/compiler/basicTypes/SrcLoc.hs
@@ -48,7 +48,7 @@ module SrcLoc (
srcSpanStart, srcSpanEnd,
realSrcSpanStart, realSrcSpanEnd,
srcSpanFileName_maybe,
- showUserSpan, pprUserRealSpan,
+ pprUserRealSpan,
-- ** Unsafely deconstructing SrcSpan
-- These are dubious exports, because they crash on some inputs
@@ -484,9 +484,6 @@ instance Outputable SrcSpan where
-- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
-- RealSrcSpan s -> ppr s
-showUserSpan :: Bool -> SrcSpan -> String
-showUserSpan show_path span = showSDocSimple (pprUserSpan show_path span)
-
pprUserSpan :: Bool -> SrcSpan -> SDoc
pprUserSpan _ (UnhelpfulSpan s) = ftext s
pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s
diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index dc2fd1cb210e..d4c3ed78085b 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -295,8 +295,26 @@ missingArgErr f = Left ("missing argument for flag: " ++ f)
-- Utils
--------------------------------------------------------
-errorsToGhcException :: [Located String] -> GhcException
+
+-- See Note [Handling errors when parsing flags]
+errorsToGhcException :: [(String, -- Location
+ String)] -- Error
+ -> GhcException
errorsToGhcException errs =
- UsageError $
- intercalate "\n" [ showUserSpan True l ++ ": " ++ e | L l e <- errs ]
+ UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ]
+
+{- Note [Handling errors when parsing commandline flags]
+
+Parsing of static and mode flags happens before any session is started, i.e.,
+before the first call to 'GHC.withGhc'. Therefore, to report errors for
+invalid usage of these two types of flags, we can not call any function that
+needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags
+is not set either). So we always print "on the commandline" as the location,
+which is true except for Api users, which is probably ok.
+
+When reporting errors for invalid usage of dynamic flags we /can/ make use of
+DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull.
+Before, we called unsafeGlobalDynFlags when an invalid (combination of)
+flag(s) was given on the commandline, resulting in panics (#9963).
+-}
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index b974d72cde0f..4c93657f9584 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -178,6 +178,7 @@ import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef
+import Control.Arrow ((&&&))
import Control.Monad
import Control.Exception (throwIO)
@@ -2087,8 +2088,10 @@ parseDynamicFlagsFull :: MonadIO m
parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
let ((leftover, errs, warns), dflags1)
= runCmdLine (processArgs activeFlags args) dflags0
- when (not (null errs)) $ liftIO $
- throwGhcExceptionIO $ errorsToGhcException errs
+
+ -- See Note [Handling errors when parsing commandline flags]
+ unless (null errs) $ liftIO $ throwGhcExceptionIO $
+ errorsToGhcException . map (showPpr dflags0 . getLoc &&& unLoc) $ errs
-- check for disabled flags in safe haskell
let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1
@@ -4159,7 +4162,8 @@ makeDynFlagsConsistent dflags
-- to show SDocs when tracing, but we don't always have DynFlags
-- available.
--
--- Do not use it if you can help it. You may get the wrong value!
+-- Do not use it if you can help it. You may get the wrong value, or this
+-- panic!
GLOBAL_VAR(v_unsafeGlobalDynFlags, panic "v_unsafeGlobalDynFlags: not initialised", DynFlags)
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 4b4403a3eacd..914a1459df4e 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, TupleSections #-}
{-# OPTIONS_GHC -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
@@ -82,7 +82,10 @@ parseStaticFlagsFull flagsAvailable args = do
when ready $ throwGhcExceptionIO (ProgramError "Too late for parseStaticFlags: call it before runGhc or runGhcT")
(leftover, errs, warns) <- processArgs flagsAvailable args
- when (not (null errs)) $ throwGhcExceptionIO $ errorsToGhcException errs
+
+ -- See Note [Handling errors when parsing commandline flags]
+ unless (null errs) $ throwGhcExceptionIO $
+ errorsToGhcException . map (("on the commandline", ) . unLoc) $ errs
-- see sanity code in staticOpts
writeIORef v_opt_C_ready True
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 279710dc19f1..958adcd07494 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -2246,8 +2246,10 @@ mkAuxBinderName parent occ_fun
uniq_parent_occ = mkOccName (occNameSpace parent_occ) uniq_string
uniq_string
- | opt_PprStyle_Debug = showSDocSimple (ppr parent_occ <> underscore <> ppr parent_uniq)
- | otherwise = show parent_uniq
+ | opt_PprStyle_Debug
+ = showSDocUnsafe (ppr parent_occ <> underscore <> ppr parent_uniq)
+ | otherwise
+ = show parent_uniq
-- The debug thing is just to generate longer, but perhaps more perspicuous, names
parent_uniq = nameUnique parent
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 488094a498c1..e350de93b1a9 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -40,7 +40,7 @@ module Outputable (
-- * Converting 'SDoc' into strings and outputing it
printForC, printForAsm, printForUser, printForUserPartWay,
pprCode, mkCodeStyle,
- showSDoc, showSDocSimple, showSDocOneLine,
+ showSDoc, showSDocUnsafe, showSDocOneLine,
showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
showSDocUnqual, showPpr,
renderWithStyle,
@@ -401,8 +401,10 @@ mkCodeStyle = PprCode
showSDoc :: DynFlags -> SDoc -> String
showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle
-showSDocSimple :: SDoc -> String
-showSDocSimple sdoc = showSDoc unsafeGlobalDynFlags sdoc
+-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be
+-- initialised yet.
+showSDocUnsafe :: SDoc -> String
+showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc
showPpr :: Outputable a => DynFlags -> a -> String
showPpr dflags thing = showSDoc dflags (ppr thing)
diff --git a/ghc/Main.hs b/ghc/Main.hs
index f0539df6cd52..d30a50b7cd25 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-}
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
@@ -517,8 +517,11 @@ parseModeFlags args = do
mode = case mModeFlag of
Nothing -> doMakeMode
Just (m, _) -> m
- errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
- when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
+
+ -- See Note [Handling errors when parsing commandline flags]
+ unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $
+ map (("on the commandline", )) $ map unLoc errs1 ++ errs2
+
return (mode, flags' ++ leftover, warns)
type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
diff --git a/testsuite/tests/driver/T9963.stderr b/testsuite/tests/driver/T9963.stderr
new file mode 100644
index 000000000000..09a9bf4a0069
--- /dev/null
+++ b/testsuite/tests/driver/T9963.stderr
@@ -0,0 +1,2 @@
+ghc-stage2: on the commandline: cannot use `--interactive' with `--print-libdir'
+Usage: For basic information, try the `--help' option.
diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T
index ed4d92484384..f236f6b5958a 100644
--- a/testsuite/tests/driver/all.T
+++ b/testsuite/tests/driver/all.T
@@ -410,3 +410,5 @@ test('write_interface_make', normal, run_command, ['$MAKE -s --no-print-director
test('T9776', normal, compile_fail, ['-frule-check'])
+test('T9963', exit_code(1), run_command,
+ ['{compiler} --interactive --print-libdir'])
--
GitLab