diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Cmm/CallConv.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/CmmToLlvm/Regs.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Flags.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Errors.hs | 16 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Errors/Ppr.hs | 28 | ||||
| -rw-r--r-- | compiler/GHC/Parser/Lexer.x | 71 | ||||
| -rw-r--r-- | compiler/GHC/Runtime/Eval.hs | 2 |
8 files changed, 107 insertions, 35 deletions
diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs index 5d591a0dd3..0f65ef2157 100644 --- a/compiler/GHC/Cmm/CallConv.hs +++ b/compiler/GHC/Cmm/CallConv.hs @@ -207,14 +207,14 @@ nodeOnly = ([VanillaReg 1], [], [], [], []) realArgRegsCover :: Platform -> [GlobalReg] realArgRegsCover platform | passFloatArgsInXmm platform - = map ($VGcPtr) (realVanillaRegs platform) ++ + = map ($ VGcPtr) (realVanillaRegs platform) ++ realLongRegs platform ++ realDoubleRegs platform -- we only need to save the low Double part of XMM registers. -- Moreover, the NCG can't load/store full XMM -- registers for now... | otherwise - = map ($VGcPtr) (realVanillaRegs platform) ++ + = map ($ VGcPtr) (realVanillaRegs platform) ++ realFloatRegs platform ++ realDoubleRegs platform ++ realLongRegs platform diff --git a/compiler/GHC/CmmToLlvm/Regs.hs b/compiler/GHC/CmmToLlvm/Regs.hs index 411ec22bbb..c4d9d12a48 100644 --- a/compiler/GHC/CmmToLlvm/Regs.hs +++ b/compiler/GHC/CmmToLlvm/Regs.hs @@ -50,12 +50,12 @@ lmGlobalReg platform suf reg VanillaReg 9 _ -> wordGlobal $ "R9" ++ suf VanillaReg 10 _ -> wordGlobal $ "R10" ++ suf SpLim -> wordGlobal $ "SpLim" ++ suf - FloatReg 1 -> floatGlobal $"F1" ++ suf - FloatReg 2 -> floatGlobal $"F2" ++ suf - FloatReg 3 -> floatGlobal $"F3" ++ suf - FloatReg 4 -> floatGlobal $"F4" ++ suf - FloatReg 5 -> floatGlobal $"F5" ++ suf - FloatReg 6 -> floatGlobal $"F6" ++ suf + FloatReg 1 -> floatGlobal $ "F1" ++ suf + FloatReg 2 -> floatGlobal $ "F2" ++ suf + FloatReg 3 -> floatGlobal $ "F3" ++ suf + FloatReg 4 -> floatGlobal $ "F4" ++ suf + FloatReg 5 -> floatGlobal $ "F5" ++ suf + FloatReg 6 -> floatGlobal $ "F6" ++ suf DoubleReg 1 -> doubleGlobal $ "D1" ++ suf DoubleReg 2 -> doubleGlobal $ "D2" ++ suf DoubleReg 3 -> doubleGlobal $ "D3" ++ suf diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 661253b856..e228c416be 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -501,6 +501,8 @@ data WarningFlag = | Opt_WarnCompatUnqualifiedImports -- Since 8.10 | Opt_WarnDerivingDefaults | Opt_WarnInvalidHaddock -- Since 8.12 + | Opt_WarnOperatorWhitespaceExtConflict -- Since 9.2 + | Opt_WarnOperatorWhitespace -- Since 9.2 deriving (Eq, Show, Enum) -- | Used when outputting warnings: if a reason is given, it is diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index ed29aa812c..2a4319ed1e 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -3330,7 +3330,9 @@ wWarningFlagsDeps = [ Opt_WarnPrepositiveQualifiedModule, flagSpec "unused-packages" Opt_WarnUnusedPackages, flagSpec "compat-unqualified-imports" Opt_WarnCompatUnqualifiedImports, - flagSpec "invalid-haddock" Opt_WarnInvalidHaddock + flagSpec "invalid-haddock" Opt_WarnInvalidHaddock, + flagSpec "operator-whitespace-ext-conflict" Opt_WarnOperatorWhitespaceExtConflict, + flagSpec "operator-whitespace" Opt_WarnOperatorWhitespace ] -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@ @@ -4087,7 +4089,8 @@ standardWarnings -- see Note [Documenting warning flags] Opt_WarnInaccessibleCode, Opt_WarnSpaceAfterBang, Opt_WarnNonCanonicalMonadInstances, - Opt_WarnNonCanonicalMonoidInstances + Opt_WarnNonCanonicalMonoidInstances, + Opt_WarnOperatorWhitespaceExtConflict ] -- | Things you get with -W diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs index b67bf32baf..cf93890532 100644 --- a/compiler/GHC/Parser/Errors.hs +++ b/compiler/GHC/Parser/Errors.hs @@ -1,6 +1,8 @@ module GHC.Parser.Errors ( Warning(..) , TransLayoutReason(..) + , OperatorWhitespaceSymbol(..) + , OperatorWhitespaceOccurrence(..) , NumUnderscoreReason(..) , Error(..) , ErrorDesc(..) @@ -57,6 +59,20 @@ data Warning | WarnImportPreQualified !SrcSpan -- ^ Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled + | WarnOperatorWhitespaceExtConflict !SrcSpan !OperatorWhitespaceSymbol + | WarnOperatorWhitespace !SrcSpan !FastString !OperatorWhitespaceOccurrence + +-- | The operator symbol in the 'WarnOperatorWhitespaceExtConflict' warning. +data OperatorWhitespaceSymbol + = OperatorWhitespaceSymbol_PrefixPercent + | OperatorWhitespaceSymbol_PrefixDollar + | OperatorWhitespaceSymbol_PrefixDollarDollar + +-- | The operator occurrence type in the 'WarnOperatorWhitespace' warning. +data OperatorWhitespaceOccurrence + = OperatorWhitespaceOccurrence_Prefix + | OperatorWhitespaceOccurrence_Suffix + | OperatorWhitespaceOccurrence_TightInfix data TransLayoutReason = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block" diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index f99cac90a4..c4b411b1c3 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -102,6 +102,34 @@ pprWarning = \case <+> text "after the module name instead." $$ text "To allow this, enable language extension 'ImportQualifiedPost'" + WarnOperatorWhitespaceExtConflict loc sym + -> mkParserWarn Opt_WarnOperatorWhitespaceExtConflict loc $ + let mk_prefix_msg operator_symbol extension_name syntax_meaning = + text "The prefix use of a" <+> quotes (text operator_symbol) + <+> text "would denote" <+> text syntax_meaning + $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.") + $$ text "Suggested fix: add whitespace after the" + <+> quotes (text operator_symbol) <> char '.' + in + case sym of + OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "%" "LinearTypes" "a multiplicity annotation" + OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "$" "TemplateHaskell" "an untyped splice" + OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "$$" "TemplateHaskell" "a typed splice" + + + WarnOperatorWhitespace loc sym occ_type + -> mkParserWarn Opt_WarnOperatorWhitespace loc $ + let mk_msg occ_type_str = + text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym) + <+> text "might be repurposed as special syntax" + $$ nest 2 (text "by a future language extension.") + $$ text "Suggested fix: add whitespace around it." + in + case occ_type of + OperatorWhitespaceOccurrence_Prefix -> mk_msg "prefix" + OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix" + OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" + pprError :: Error -> ErrMsg pprError err = mkParserErr (errLoc err) $ vcat (pp_err (errDesc err) : map pp_hint (errHints err)) diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 654db86651..17f6dd0e65 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -1572,42 +1572,65 @@ qconsym buf len = ITqconsym $! splitQualName buf len False -- See Note [Whitespace-sensitive operator parsing] varsym_prefix :: Action -varsym_prefix = sym $ \exts s -> - if | s == fsLit "@" -- regardless of TypeApplications for better error messages - -> return ITtypeApp - | LinearTypesBit `xtest` exts, s == fsLit "%" - -> return ITpercent - | ThQuotesBit `xtest` exts, s == fsLit "$" - -> return ITdollar - | ThQuotesBit `xtest` exts, s == fsLit "$$" - -> return ITdollardollar - | s == fsLit "-" -- Only when LexicalNegation is on, otherwise we get ITminus and - -- don't hit this code path. See Note [Minus tokens] - -> return ITprefixminus +varsym_prefix = sym $ \span exts s -> + let warnExtConflict errtok = + do { addWarning Opt_WarnOperatorWhitespaceExtConflict $ + WarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok + ; return (ITvarsym s) } + in + if | s == fsLit "@" -> + return ITtypeApp -- regardless of TypeApplications for better error messages + | s == fsLit "%" -> + if xtest LinearTypesBit exts + then return ITpercent + else warnExtConflict OperatorWhitespaceSymbol_PrefixPercent + | s == fsLit "$" -> + if xtest ThQuotesBit exts + then return ITdollar + else warnExtConflict OperatorWhitespaceSymbol_PrefixDollar + | s == fsLit "$$" -> + if xtest ThQuotesBit exts + then return ITdollardollar + else warnExtConflict OperatorWhitespaceSymbol_PrefixDollarDollar + | s == fsLit "-" -> + return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus + -- and don't hit this code path. See Note [Minus tokens] | s == fsLit "!" -> return ITbang | s == fsLit "~" -> return ITtilde - | otherwise -> return (ITvarsym s) + | otherwise -> + do { addWarning Opt_WarnOperatorWhitespace $ + WarnOperatorWhitespace (mkSrcSpanPs span) s + OperatorWhitespaceOccurrence_Prefix + ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] varsym_suffix :: Action -varsym_suffix = sym $ \_ s -> +varsym_suffix = sym $ \span _ s -> if | s == fsLit "@" -> failMsgP (Error ErrSuffixAT []) - | otherwise -> return (ITvarsym s) + | otherwise -> + do { addWarning Opt_WarnOperatorWhitespace $ + WarnOperatorWhitespace (mkSrcSpanPs span) s + OperatorWhitespaceOccurrence_Suffix + ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] varsym_tight_infix :: Action -varsym_tight_infix = sym $ \_ s -> +varsym_tight_infix = sym $ \span _ s -> if | s == fsLit "@" -> return ITat - | otherwise -> return (ITvarsym s) + | otherwise -> + do { addWarning Opt_WarnOperatorWhitespace $ + WarnOperatorWhitespace (mkSrcSpanPs span) s + OperatorWhitespaceOccurrence_TightInfix + ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] varsym_loose_infix :: Action -varsym_loose_infix = sym (\_ s -> return $ ITvarsym s) +varsym_loose_infix = sym (\_ _ s -> return $ ITvarsym s) consym :: Action -consym = sym (\_exts s -> return $ ITconsym s) +consym = sym (\_span _exts s -> return $ ITconsym s) -sym :: (ExtsBitmap -> FastString -> P Token) -> Action +sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action sym con span buf len = case lookupUFM reservedSymsFM fs of Just (keyword, NormalSyntax, 0) -> @@ -1616,20 +1639,20 @@ sym con span buf len = exts <- getExts if exts .&. i /= 0 then return $ L span keyword - else L span <$!> con exts fs + else L span <$!> con span exts fs Just (keyword, UnicodeSyntax, 0) -> do exts <- getExts if xtest UnicodeSyntaxBit exts then return $ L span keyword - else L span <$!> con exts fs + else L span <$!> con span exts fs Just (keyword, UnicodeSyntax, i) -> do exts <- getExts if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts then return $ L span keyword - else L span <$!> con exts fs + else L span <$!> con span exts fs Nothing -> do exts <- getExts - L span <$!> con exts fs + L span <$!> con span exts fs where !fs = lexemeToFastString buf len diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index fa9e80ecfd..68d2908dbb 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -427,7 +427,7 @@ resumeExec canLogSpan step hist' = case mb_brkpt of Nothing -> prevHistoryLst Just bi - | not $canLogSpan span -> prevHistoryLst + | not $ canLogSpan span -> prevHistoryLst | otherwise -> mkHistory hsc_env apStack bi `consBL` fromListBL 50 hist handleRunStatus step expr bindings final_ids status hist' |