diff options
Diffstat (limited to 'compiler/GHC/Core/Lint.hs')
| -rw-r--r-- | compiler/GHC/Core/Lint.hs | 117 |
1 files changed, 30 insertions, 87 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 00636ec444..c6f4fdf42f 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -19,11 +19,9 @@ module GHC.Core.Lint ( WarnsAndErrs, lintCoreBindings', lintUnfolding, - lintPassResult', lintExpr, + lintPassResult, lintExpr, lintAnnots, lintAxioms, - interactiveInScope, - -- ** Debug output EndPassConfig (..), endPassIO, @@ -37,13 +35,11 @@ import GHC.Driver.Session import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree ) import GHC.Unit.Module.ModGuts import GHC.Platform -import GHC.Runtime.Context import GHC.Core import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Stats ( coreBindsStats ) -import GHC.Core.Opt.Monad import GHC.Core.DataCon import GHC.Core.Ppr import GHC.Core.Coercion @@ -57,10 +53,11 @@ import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars ) import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify -import GHC.Core.InstEnv ( instanceDFunId, instEnvElts ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Opt.Arity ( typeArity ) +import GHC.Core.Opt.Monad + import GHC.Types.Literal import GHC.Types.Var as Var import GHC.Types.Var.Env @@ -74,7 +71,6 @@ import GHC.Types.Tickish import GHC.Types.RepType import GHC.Types.Basic import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv ) -import GHC.Types.TypeEnv import GHC.Builtin.Names import GHC.Builtin.Types.Prim @@ -283,24 +279,30 @@ data EndPassConfig = EndPassConfig , ep_lintPassResult :: !(Maybe LintPassResultConfig) -- ^ Whether we should lint the result of this pass. + + , ep_printUnqual :: !PrintUnqualified + + , ep_dumpFlag :: !(Maybe DumpFlag) + + , ep_prettyPass :: !SDoc + + , ep_passDetails :: !SDoc } endPassIO :: Logger -> EndPassConfig - -> PrintUnqualified - -> CoreToDo -> CoreProgram -> [CoreRule] + -> CoreProgram -> [CoreRule] -> IO () -- Used by the IO-is CorePrep too -endPassIO logger cfg print_unqual - pass binds rules - = do { dumpPassResult logger (ep_dumpCoreSizes cfg) print_unqual mb_flag - (renderWithContext defaultSDocContext (ppr pass)) - (pprPassDetails pass) binds rules +endPassIO logger cfg binds rules + = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_printUnqual cfg) mb_flag + (renderWithContext defaultSDocContext (ep_prettyPass cfg)) + (ep_passDetails cfg) binds rules ; for_ (ep_lintPassResult cfg) $ \lp_cfg -> - lintPassResult' logger lp_cfg pass binds + lintPassResult logger lp_cfg binds } where - mb_flag = case coreDumpFlag pass of + mb_flag = case ep_dumpFlag cfg of Just flag | logHasDumpFlag logger flag -> Just flag | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag _ -> Nothing @@ -338,33 +340,6 @@ dumpPassResult logger dump_core_sizes unqual mb_flag hdr extra_info binds rules , text "------ Local rules for imported ids --------" , pprRules rules ] -coreDumpFlag :: CoreToDo -> Maybe DumpFlag -coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core -coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core -coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core -coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity -coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify -coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal -coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal -coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper -coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec -coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec -coreDumpFlag CoreCSE = Just Opt_D_dump_cse -coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt -coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds -coreDumpFlag CoreTidy = Just Opt_D_dump_simpl -coreDumpFlag CorePrep = Just Opt_D_dump_prep - -coreDumpFlag CoreAddCallerCcs = Nothing -coreDumpFlag CoreAddLateCcs = Nothing -coreDumpFlag CoreDoPrintCore = Nothing -coreDumpFlag (CoreDoRuleCheck {}) = Nothing -coreDumpFlag CoreDoNothing = Nothing -coreDumpFlag (CoreDoPasses {}) = Nothing - {- ************************************************************************ * * @@ -374,28 +349,30 @@ coreDumpFlag (CoreDoPasses {}) = Nothing -} data LintPassResultConfig = LintPassResultConfig - { lpr_diagOpts :: !DiagOpts - , lpr_platform :: !Platform - , lpr_makeLintFlags :: !(CoreToDo -> LintFlags) - , lpr_localsInScope :: ![Var] + { lpr_diagOpts :: !DiagOpts + , lpr_platform :: !Platform + , lpr_makeLintFlags :: !LintFlags + , lpr_showLintWarnings :: !Bool + , lpr_passPpr :: !SDoc + , lpr_localsInScope :: ![Var] } -lintPassResult' :: Logger -> LintPassResultConfig - -> CoreToDo -> CoreProgram -> IO () -lintPassResult' logger cfg pass binds +lintPassResult :: Logger -> LintPassResultConfig + -> CoreProgram -> IO () +lintPassResult logger cfg binds = do { let warns_and_errs = lintCoreBindings' (LintConfig { l_diagOpts = lpr_diagOpts cfg , l_platform = lpr_platform cfg - , l_flags = lpr_makeLintFlags cfg pass + , l_flags = lpr_makeLintFlags cfg , l_vars = lpr_localsInScope cfg }) binds ; Err.showPass logger $ "Core Linted result of " ++ - renderWithContext defaultSDocContext (ppr pass) + renderWithContext defaultSDocContext (lpr_passPpr cfg) ; displayLintResults logger - (showLintWarnings pass) (ppr pass) + (lpr_showLintWarnings cfg) (lpr_passPpr cfg) (pprCoreBindings binds) warns_and_errs } @@ -432,40 +409,6 @@ lint_banner string pass = text "*** Core Lint" <+> text string <+> text ": in result of" <+> pass <+> text "***" -showLintWarnings :: CoreToDo -> Bool --- Disable Lint warnings on the first simplifier pass, because --- there may be some INLINE knots still tied, which is tiresomely noisy -showLintWarnings (CoreDoSimplify cfg) = case sm_phase (cds_mode cfg) of - InitialPhase -> False - _ -> True -showLintWarnings _ = True - -interactiveInScope :: InteractiveContext -> [Var] --- In GHCi we may lint expressions, or bindings arising from 'deriving' --- clauses, that mention variables bound in the interactive context. --- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context). --- So we have to tell Lint about them, lest it reports them as out of scope. --- --- We do this by find local-named things that may appear free in interactive --- context. This function is pretty revolting and quite possibly not quite right. --- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty --- so this is a (cheap) no-op. --- --- See #8215 for an example -interactiveInScope ictxt - = tyvars ++ ids - where - -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr - (cls_insts, _fam_insts) = ic_instances ictxt - te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) - te = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts cls_insts) - ids = typeEnvIds te - tyvars = tyCoVarsOfTypesList $ map idType ids - -- Why the type variables? How can the top level envt have free tyvars? - -- I think it's because of the GHCi debugger, which can bind variables - -- f :: [t] -> [t] - -- where t is a RuntimeUnk (see TcType) - -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs -- Returns (warnings, errors) |