diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2020-10-31 11:41:45 -0400 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-11-02 23:46:55 -0500 |
commit | bfb1e272950169c17963adaf423890e47b908f4d (patch) | |
tree | 0cd4d11f2df808acfb2a831a647397724f8a2504 | |
parent | 81006a06736c7300626f9d692a118b493b585cd5 (diff) | |
download | haskell-bfb1e272950169c17963adaf423890e47b908f4d.tar.gz |
Display results of GHC.Core.Lint.lint* functions consistently
Previously, the functions in `GHC.Core.Lint` used a patchwork of
different ways to display Core Lint errors:
* `lintPassResult` (which is the source of most Core Lint errors) renders
Core Lint errors with a distinctive banner (e.g.,
`*** Core Lint errors : in result of ... ***`) that sets them apart
from ordinary GHC error messages.
* `lintAxioms`, in contrast, uses a completely different code path that
displays Core Lint errors in a rather confusing manner. For example,
the program in #18770 would give these results:
```
Bug.hs:1:1: error:
Bug.hs:12:1: warning:
Non-*-like kind when *-like expected: RuntimeRep
when checking the body of forall: 'TupleRep '[r]
In the coercion axiom Bug.N:T :: []. Bug.T ~_R Any
Substitution: [TCvSubst
In scope: InScope {r}
Type env: [axl :-> r]
Co env: []]
|
1 | {-# LANGUAGE DataKinds #-}
| ^
```
* Further digging reveals that `GHC.IfaceToCore` displays Core Lint
errors for iface unfoldings as though they were a GHC panic. See, for
example, this excerpt from #17723:
```
ghc: panic! (the 'impossible' happened)
(GHC version 8.8.2 for x86_64-unknown-linux):
Iface Lint failure
In interface for Lib
...
```
This patch makes all of these code paths display Core Lint errors and
warnings consistently. I decided to adopt the conventions that
`lintPassResult` currently uses, as they appear to have been around the
longest (and look the best, in my subjective opinion). We now use the
`displayLintResult` function for all three scenarios mentioned above.
For example, here is what the Core Lint error for the program in #18770 looks
like after this patch:
```
[1 of 1] Compiling Bug ( Bug.hs, Bug.o )
*** Core Lint errors : in result of TcGblEnv axioms ***
Bug.hs:12:1: warning:
Non-*-like kind when *-like expected: RuntimeRep
when checking the body of forall: 'TupleRep '[r_axn]
In the coercion axiom N:T :: []. T ~_R Any
Substitution: [TCvSubst
In scope: InScope {r_axn}
Type env: [axn :-> r_axn]
Co env: []]
*** Offending Program ***
axiom N:T :: T = Any -- Defined at Bug.hs:12:1
*** End of Offense ***
<no location info>: error:
Compilation had errors
```
Fixes #18770.
-rw-r--r-- | compiler/GHC/Core/Lint.hs | 75 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/IfaceToCore.hs | 25 | ||||
-rw-r--r-- | compiler/GHC/Tc/Module.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Tc/Types.hs | 5 | ||||
-rw-r--r-- | testsuite/tests/callarity/unittest/CallArity1.hs | 2 |
6 files changed, 54 insertions, 63 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 5104b00c61..a61b788dc9 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -19,8 +19,8 @@ module GHC.Core.Lint ( -- ** Debug output endPass, endPassIO, - dumpPassResult, - GHC.Core.Lint.dumpIfSet, + displayLintResults, dumpPassResult, + dumpIfSet, ) where #include "HsVersions.h" @@ -65,7 +65,8 @@ import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify import GHC.Types.Basic -import GHC.Utils.Error as Err +import GHC.Utils.Error hiding ( dumpIfSet ) +import qualified GHC.Utils.Error as Err import GHC.Data.List.SetOps import GHC.Builtin.Names import GHC.Utils.Outputable as Outputable @@ -372,33 +373,38 @@ lintPassResult hsc_env pass binds | not (gopt Opt_DoCoreLinting dflags) = return () | otherwise - = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds + = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass) - ; displayLintResults dflags pass warns errs binds } + ; displayLintResults dflags (showLintWarnings pass) (ppr pass) + (pprCoreBindings binds) warns_and_errs } where dflags = hsc_dflags hsc_env -displayLintResults :: DynFlags -> CoreToDo - -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram +displayLintResults :: DynFlags + -> Bool -- ^ If 'True', display linter warnings. + -- If 'False', ignore linter warnings. + -> SDoc -- ^ The source of the linted program + -> SDoc -- ^ The linted program, pretty-printed + -> WarnsAndErrs -> IO () -displayLintResults dflags pass warns errs binds +displayLintResults dflags display_warnings pp_what pp_pgm (warns, errs) | not (isEmptyBag errs) = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan $ withPprStyle defaultDumpStyle - (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs + (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs , text "*** Offending Program ***" - , pprCoreBindings binds + , pp_pgm , text "*** End of Offense ***" ]) ; Err.ghcExit dflags 1 } | not (isEmptyBag warns) , not (hasNoDebugOutput dflags) - , showLintWarnings pass + , display_warnings -- If the Core linter encounters an error, output to stderr instead of -- stdout (#13342) = putLogMsg dflags NoReason Err.SevInfo noSrcSpan $ withPprStyle defaultDumpStyle - (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) + (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) | otherwise = return () @@ -413,29 +419,18 @@ showLintWarnings :: CoreToDo -> Bool showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False showLintWarnings _ = True -lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO () +lintInteractiveExpr :: SDoc -- ^ The source of the linted expression + -> HscEnv -> CoreExpr -> IO () lintInteractiveExpr what hsc_env expr | not (gopt Opt_DoCoreLinting dflags) = return () | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr - = do { display_lint_err err - ; Err.ghcExit dflags 1 } + = displayLintResults dflags False what (pprCoreExpr expr) (emptyBag, err) | otherwise = return () where dflags = hsc_dflags hsc_env - display_lint_err err - = do { putLogMsg dflags NoReason Err.SevDump - noSrcSpan - $ withPprStyle defaultDumpStyle - (vcat [ lint_banner "errors" (text what) - , err - , text "*** Offending Program ***" - , pprCoreExpr expr - , text "*** End of Offense ***" ]) - ; Err.ghcExit dflags 1 } - interactiveInScope :: HscEnv -> [Var] -- In GHCi we may lint expressions, or bindings arising from 'deriving' -- clauses, that mention variables bound in the interactive context. @@ -464,7 +459,7 @@ interactiveInScope hsc_env -- where t is a RuntimeUnk (see TcType) -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. -lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) +lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs -- Returns (warnings, errors) -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] @@ -540,16 +535,16 @@ hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore. -} -lintUnfolding :: Bool -- True <=> is a compulsory unfolding +lintUnfolding :: Bool -- True <=> is a compulsory unfolding -> DynFlags -> SrcLoc - -> VarSet -- Treat these as in scope + -> VarSet -- Treat these as in scope -> CoreExpr - -> Maybe MsgDoc -- Nothing => OK + -> Maybe (Bag MsgDoc) -- Nothing => OK lintUnfolding is_compulsory dflags locn var_set expr | isEmptyBag errs = Nothing - | otherwise = Just (pprMessageBag errs) + | otherwise = Just errs where vars = nonDetEltsUniqSet var_set (_warns, errs) = initL dflags (defaultLintFlags dflags) vars $ @@ -563,11 +558,11 @@ lintUnfolding is_compulsory dflags locn var_set expr lintExpr :: DynFlags -> [Var] -- Treat these as in scope -> CoreExpr - -> Maybe MsgDoc -- Nothing => OK + -> Maybe (Bag MsgDoc) -- Nothing => OK lintExpr dflags vars expr | isEmptyBag errs = Nothing - | otherwise = Just (pprMessageBag errs) + | otherwise = Just errs where (_warns, errs) = initL dflags (defaultLintFlags dflags) vars linter linter = addLoc TopLevelBindings $ @@ -2326,13 +2321,15 @@ lintCoercion (HoleCo h) -} lintAxioms :: DynFlags + -> SDoc -- ^ The source of the linted axioms -> [CoAxiom Branched] - -> WarnsAndErrs -lintAxioms dflags axioms - = initL dflags (defaultLintFlags dflags) [] $ - do { mapM_ lint_axiom axioms - ; let axiom_groups = groupWith coAxiomTyCon axioms - ; mapM_ lint_axiom_group axiom_groups } + -> IO () +lintAxioms dflags what axioms = + displayLintResults dflags True what (vcat $ map pprCoAxiom axioms) $ + initL dflags (defaultLintFlags dflags) [] $ + do { mapM_ lint_axiom axioms + ; let axiom_groups = groupWith coAxiomTyCon axioms + ; mapM_ lint_axiom_group axiom_groups } lint_axiom :: CoAxiom Branched -> LintM () lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index d12099f21b..0f5476634e 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -1713,7 +1713,7 @@ hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do -- Desugar it ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr - liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr) + liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr) handleWarnings -- Then code-gen, and link it @@ -1955,7 +1955,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr ; prepd_expr <- corePrepExpr hsc_env tidy_expr {- Lint if necessary -} - ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr + ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr {- Convert to BCOs -} ; bcos <- coreExprToBCOs hsc_env diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 6a4861c727..de0fa6f023 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -62,6 +62,7 @@ import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.Ppr import GHC.Unit.External import GHC.Unit.Module @@ -73,6 +74,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Data.Bag import GHC.Data.Maybe import GHC.Data.FastString import GHC.Data.List.SetOps @@ -1199,13 +1201,11 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd bndrs' ++ exprsFreeIdsList args') ; case lintExpr dflags in_scope rhs' of - Nothing -> return () - Just fail_msg -> do { mod <- getIfModule - ; pprPanic "Iface Lint failure" - (vcat [ text "In interface for" <+> ppr mod - , hang doc 2 fail_msg - , ppr name <+> equals <+> ppr rhs' - , text "Iface expr =" <+> ppr rhs ]) } } + Nothing -> return () + Just errs -> liftIO $ + displayLintResults dflags False doc + (pprCoreExpr rhs') + (emptyBag, errs) } ; return (bndrs', args', rhs') } ; let mb_tcs = map ifTopFreeName args ; this_mod <- getIfModule @@ -1724,13 +1724,10 @@ tcPragExpr is_compulsory toplvl name expr in_scope <- get_in_scope dflags <- getDynFlags case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of - Nothing -> return () - Just fail_msg -> do { mod <- getIfModule - ; pprPanic "Iface Lint failure" - (vcat [ text "In interface for" <+> ppr mod - , hang doc 2 fail_msg - , ppr name <+> equals <+> ppr core_expr' - , text "Iface expr =" <+> ppr expr ]) } + Nothing -> return () + Just errs -> liftIO $ + displayLintResults dflags False doc + (pprCoreExpr core_expr') (emptyBag, errs) return core_expr' where doc = ppWhen is_compulsory (text "Compulsory") <+> diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 40a59f965d..10461ad5fe 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -296,11 +296,7 @@ tcRnModuleTcRnM hsc_env mod_sum tcRnSrcDecls explicit_mod_hdr local_decls export_ies ; whenM (goptM Opt_DoCoreLinting) $ - do { let (warns, errs) = lintGblEnv (hsc_dflags hsc_env) tcg_env - ; mapBagM_ (addWarn NoReason) warns - ; mapBagM_ addErr errs - ; failIfErrsM } -- if we have a lint error, we're only - -- going to get in deeper trouble by proceeding + lintGblEnv (hsc_dflags hsc_env) tcg_env ; setGblEnv tcg_env $ do { -- Process the export list diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 3cda5de56f..2f41bb4b14 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -1712,7 +1712,8 @@ getRoleAnnots bndrs role_env -- | Check the 'TcGblEnv' for consistency. Currently, only checks -- axioms, but should check other aspects, too. -lintGblEnv :: DynFlags -> TcGblEnv -> (Bag SDoc, Bag SDoc) -lintGblEnv dflags tcg_env = lintAxioms dflags axioms +lintGblEnv :: DynFlags -> TcGblEnv -> TcM () +lintGblEnv dflags tcg_env = + liftIO $ lintAxioms dflags (text "TcGblEnv axioms") axioms where axioms = typeEnvCoAxioms (tcg_type_env tcg_env) diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs index 0ec56b8894..7ac0303820 100644 --- a/testsuite/tests/callarity/unittest/CallArity1.hs +++ b/testsuite/tests/callarity/unittest/CallArity1.hs @@ -172,7 +172,7 @@ main = do dflags <- getSessionDynFlags liftIO $ forM_ exprs $ \(n,e) -> do case lintExpr dflags [f,scrutf,scruta] e of - Just msg -> putMsg dflags (msg $$ text "in" <+> text n) + Just errs -> putMsg dflags (pprMessageBag errs $$ text "in" <+> text n) Nothing -> return () putMsg dflags (text n Outputable.<> char ':') -- liftIO $ putMsg dflags (ppr e) |