diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/basicTypes/SrcLoc.hs | 5 | ||||
| -rw-r--r-- | compiler/main/CmdLineParser.hs | 24 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 10 | ||||
| -rw-r--r-- | compiler/main/StaticFlags.hs | 7 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenDeriv.hs | 6 | ||||
| -rw-r--r-- | compiler/utils/Outputable.hs | 8 |
6 files changed, 43 insertions, 17 deletions
diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index 4f6cc1a17d..362a925992 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 422fa13eb5..dad7ea7ae2 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 aa6b7f9308..2c1a82c787 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) @@ -2108,8 +2109,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 @@ -4200,7 +4203,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 4b4403a3ea..914a1459df 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 7802a22f87..6216ec2079 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -2274,8 +2274,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 c557224fc1..e6e8e02dda 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, @@ -406,8 +406,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) |