1 files changed, 56 insertions, 42 deletions

diff --git a/compiler/GHC/Driver/Config/Core/Lint.hs b/compiler/GHC/Driver/Config/Core/Lint.hs
index e96aedaf8e..cde05fa8b7 100644
--- a/compiler/GHC/Driver/Config/Core/Lint.hs
+++ b/compiler/GHC/Driver/Config/Core/Lint.hs
@@ -1,9 +1,7 @@
 module GHC.Driver.Config.Core.Lint
   ( endPass
   , endPassHscEnvIO
-  , lintPassResult
   , lintCoreBindings
-  , lintInteractiveExpr
   , initEndPassConfig
   , initLintPassResultConfig
   , initLintConfig
@@ -18,15 +16,15 @@ import GHC.Driver.Session
 import GHC.Driver.Config.Diagnostic
 
 import GHC.Core
-import GHC.Core.Ppr
+import GHC.Core.Lint
+import GHC.Core.Lint.Interactive
+import GHC.Core.Opt.Pipeline.Types
+import GHC.Core.Opt.Simplify ( SimplifyOpts(..) )
+import GHC.Core.Opt.Simplify.Env ( SimplMode(..) )
 import GHC.Core.Opt.Monad
 import GHC.Core.Coercion
 
-import GHC.Core.Lint
-
-import GHC.Runtime.Context
-
-import GHC.Data.Bag
+import GHC.Types.Basic ( CompilerPhase(..) )
 
 import GHC.Utils.Outputable as Outputable
 
@@ -50,22 +48,10 @@ endPassHscEnvIO hsc_env print_unqual pass binds rules
   = do { let dflags  = hsc_dflags hsc_env
        ; endPassIO
            (hsc_logger hsc_env)
-           (initEndPassConfig (hsc_IC hsc_env) dflags)
-           print_unqual pass binds rules
+           (initEndPassConfig dflags (interactiveInScope $ hsc_IC hsc_env) print_unqual pass)
+           binds rules
        }
 
-lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
-lintPassResult hsc_env pass binds
-  | not (gopt Opt_DoCoreLinting dflags)
-  = return ()
-  | otherwise
-  = lintPassResult'
-    (hsc_logger hsc_env)
-    (initLintPassResultConfig (hsc_IC hsc_env) dflags)
-    pass binds
-  where
-    dflags = hsc_dflags hsc_env
-
 -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
 lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
 lintCoreBindings dflags coreToDo vars -- binds
@@ -76,35 +62,63 @@ lintCoreBindings dflags coreToDo vars -- binds
       , l_vars     = vars
       }
 
-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 (initLintConfig dflags $ interactiveInScope $ hsc_IC hsc_env) expr
-  = displayLintResults logger False what (pprCoreExpr expr) (emptyBag, err)
-  | otherwise
-  = return ()
-  where
-    dflags = hsc_dflags hsc_env
-    logger = hsc_logger hsc_env
-
-initEndPassConfig :: InteractiveContext -> DynFlags -> EndPassConfig
-initEndPassConfig ic dflags = EndPassConfig
+initEndPassConfig :: DynFlags -> [Var] -> PrintUnqualified -> CoreToDo -> EndPassConfig
+initEndPassConfig dflags extra_vars print_unqual pass = EndPassConfig
   { ep_dumpCoreSizes = not (gopt Opt_SuppressCoreSizes dflags)
   , ep_lintPassResult = if gopt Opt_DoCoreLinting dflags
-      then Just $ initLintPassResultConfig ic dflags
+      then Just $ initLintPassResultConfig dflags extra_vars pass
       else Nothing
+  , ep_printUnqual = print_unqual
+  , ep_dumpFlag = coreDumpFlag pass
+  , ep_prettyPass = ppr pass
+  , ep_passDetails = pprPassDetails pass
   }
 
-initLintPassResultConfig :: InteractiveContext -> DynFlags -> LintPassResultConfig
-initLintPassResultConfig ic dflags = LintPassResultConfig
+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
+
+initLintPassResultConfig :: DynFlags -> [Var] -> CoreToDo -> LintPassResultConfig
+initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig
   { lpr_diagOpts      = initDiagOpts dflags
   , lpr_platform      = targetPlatform dflags
-  , lpr_makeLintFlags = perPassFlags dflags
-  , lpr_localsInScope = interactiveInScope ic
+  , lpr_makeLintFlags = perPassFlags dflags pass
+  , lpr_showLintWarnings = showLintWarnings pass
+  , lpr_passPpr = ppr pass
+  , lpr_localsInScope = extra_vars
   }
 
+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 (so_mode cfg) of
+  InitialPhase -> False
+  _ -> True
+showLintWarnings _ = True
+
 perPassFlags :: DynFlags -> CoreToDo -> LintFlags
 perPassFlags dflags pass
   = (defaultLintFlags dflags)