diff options
Diffstat (limited to 'compiler/GHC/Core')
| -rw-r--r-- | compiler/GHC/Core/Lint.hs | 76 |
1 files changed, 36 insertions, 40 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 6fdcb02c8c..1988322dd4 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" @@ -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 |