[Git][ghc/ghc][wip/T18770] Display results of GHC.Core.Lint.lint* functions consistently
Ryan Scott
gitlab at gitlab.haskell.org
Sat Oct 31 20:02:28 UTC 2020
Ryan Scott pushed to branch wip/T18770 at Glasgow Haskell Compiler / GHC
Commits:
13d53c37 by Ryan Scott at 2020-10-31T16:01:26-04:00
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.
- - - - -
6 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types.hs
- testsuite/tests/callarity/unittest/CallArity1.hs
Changes:
=====================================
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"
@@ -51,7 +51,6 @@ import GHC.Types.Name.Env
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.Ppr
-import GHC.Utils.Error
import GHC.Core.Coercion
import GHC.Types.SrcLoc
import GHC.Core.Type as Type
@@ -66,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
@@ -373,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 ()
where
@@ -415,29 +420,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.
@@ -466,7 +460,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]
@@ -542,16 +536,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 $
@@ -565,11 +559,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 $
@@ -2328,13 +2322,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
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1715,7 +1715,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
@@ -1958,7 +1958,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
=====================================
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
@@ -1725,13 +1725,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") <+>
=====================================
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
=====================================
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)
=====================================
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)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13d53c37b1f33b1ca3e6a18289215e861a1a2601
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13d53c37b1f33b1ca3e6a18289215e861a1a2601
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201031/5854c763/attachment-0001.html>
More information about the ghc-commits
mailing list