Core.Lint: Reduce `DynFlags` and `HscEnv`wip/no-state-core-lint

Co-Authored-By: Andre Marianiello <andremarianiello@users.noreply.github.com>

14 files changed, 300 insertions, 157 deletions

diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 0511a4004d..f9cac8af61 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -12,26 +12,30 @@ See Note [Core Lint guarantee].
 -}
 
 module GHC.Core.Lint (
-    lintCoreBindings, lintUnfolding,
-    lintPassResult, lintInteractiveExpr, lintExpr,
+    LintPassResultConfig (..),
+    LintFlags (..),
+    StaticPtrCheck (..),
+    LintConfig (..),
+    WarnsAndErrs,
+
+    lintCoreBindings', lintUnfolding,
+    lintPassResult', lintExpr,
     lintAnnots, lintAxioms,
 
     interactiveInScope,
 
     -- ** Debug output
-    endPass, endPassIO,
+    endPassIO,
     displayLintResults, dumpPassResult
  ) where
 
 import GHC.Prelude
 
 import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Env
-import GHC.Driver.Config.Diagnostic
 
 import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree )
 import GHC.Unit.Module.ModGuts
+import GHC.Platform
 import GHC.Runtime.Context
 
 import GHC.Core
@@ -60,7 +64,6 @@ import GHC.Types.Literal
 import GHC.Types.Var as Var
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
-import GHC.Types.Unique.Set( nonDetEltsUniqSet )
 import GHC.Types.Name
 import GHC.Types.Name.Env
 import GHC.Types.Id
@@ -95,7 +98,6 @@ import Data.List.NonEmpty ( NonEmpty(..), groupWith )
 import Data.List          ( partition )
 import Data.Maybe
 import GHC.Data.Pair
-import qualified GHC.LanguageExtensions as LangExt
 
 {-
 Note [Core Lint guarantee]
@@ -269,29 +271,24 @@ points but not the RHSes of value bindings (thunks and functions).
                  Beginning and ending passes
 *                                                                      *
 ************************************************************************
-
-These functions are not CoreM monad stuff, but they probably ought to
-be, and it makes a convenient place for them.  They print out stuff
-before and after core passes, and do Core Lint when necessary.
 -}
 
-endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
-endPass pass binds rules
-  = do { hsc_env <- getHscEnv
-       ; print_unqual <- getPrintUnqualified
-       ; liftIO $ endPassIO hsc_env print_unqual pass binds rules }
-
-endPassIO :: HscEnv -> PrintUnqualified
-          -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
+endPassIO :: Logger
+           -> LintPassResultConfig
+           -> Bool -- dump core sizes
+           -> Bool -- lint pass result
+           -> PrintUnqualified
+           -> CoreToDo -> CoreProgram -> [CoreRule]
+           -> IO ()
 -- Used by the IO-is CorePrep too
-endPassIO hsc_env print_unqual pass binds rules
+endPassIO logger lp_cfg dump_core_sizes lint_pass_result print_unqual
+           pass binds rules
   = do { dumpPassResult logger dump_core_sizes print_unqual mb_flag
-                        (showSDoc dflags (ppr pass)) (pprPassDetails pass) binds rules
-       ; lintPassResult hsc_env pass binds }
+                        (renderWithContext defaultSDocContext (ppr pass))
+                        (pprPassDetails pass) binds rules
+       ; when lint_pass_result $ lintPassResult' logger lp_cfg pass binds
+       }
   where
-    dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags)
-    logger  = hsc_logger hsc_env
-    dflags  = hsc_dflags hsc_env
     mb_flag = case coreDumpFlag pass of
                 Just flag | logHasDumpFlag logger flag                    -> Just flag
                           | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag
@@ -366,18 +363,31 @@ coreDumpFlag (CoreDoPasses {})        = Nothing
 ************************************************************************
 -}
 
-lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
-lintPassResult hsc_env pass binds
-  | not (gopt Opt_DoCoreLinting dflags)
-  = return ()
-  | otherwise
-  = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope $ hsc_IC hsc_env) binds
-       ; Err.showPass logger ("Core Linted result of " ++ showPpr dflags pass)
-       ; displayLintResults logger (showLintWarnings pass) (ppr pass)
-                            (pprCoreBindings binds) warns_and_errs }
-  where
-    dflags = hsc_dflags hsc_env
-    logger = hsc_logger hsc_env
+data LintPassResultConfig = LintPassResultConfig
+  { endPass_diagOpts      :: !DiagOpts
+  , endPass_platform      :: !Platform
+  , endPass_makeLinkFlags :: CoreToDo -> LintFlags
+  , endPass_localsInScope :: ![Var]
+  }
+
+lintPassResult' :: Logger -> LintPassResultConfig
+                -> CoreToDo -> CoreProgram -> IO ()
+lintPassResult' logger cfg pass binds
+  = do { let warns_and_errs = lintCoreBindings'
+               (LintConfig
+                { l_diagOpts = endPass_diagOpts cfg
+                , l_platform = endPass_platform cfg
+                , l_flags    = endPass_makeLinkFlags cfg pass
+                , l_vars     = endPass_localsInScope cfg
+                })
+               binds
+       ; Err.showPass logger $
+           "Core Linted result of " ++
+           renderWithContext defaultSDocContext (ppr pass)
+       ; displayLintResults logger
+                            (showLintWarnings pass) (ppr pass)
+                            (pprCoreBindings binds) warns_and_errs
+       }
 
 displayLintResults :: Logger
                    -> Bool -- ^ If 'True', display linter warnings.
@@ -418,19 +428,6 @@ showLintWarnings :: CoreToDo -> Bool
 showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
 showLintWarnings _ = True
 
-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_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
-
 interactiveInScope :: InteractiveContext -> [Var]
 -- In GHCi we may lint expressions, or bindings arising from 'deriving'
 -- clauses, that mention variables bound in the interactive context.
@@ -458,12 +455,12 @@ interactiveInScope ictxt
               -- where t is a RuntimeUnk (see TcType)
 
 -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
-lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
+lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs
 --   Returns (warnings, errors)
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
-lintCoreBindings dflags pass local_in_scope binds
-  = initL dflags flags local_in_scope $
+lintCoreBindings' cfg binds
+  = initL cfg $
     addLoc TopLevelBindings           $
     do { checkL (null dups) (dupVars dups)
        ; checkL (null ext_dups) (dupExtVars ext_dups)
@@ -476,49 +473,6 @@ lintCoreBindings dflags pass local_in_scope binds
      -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal"
     binders = map fst all_pairs
 
-    flags = (defaultLintFlags dflags)
-               { lf_check_global_ids = check_globals
-               , lf_check_inline_loop_breakers = check_lbs
-               , lf_check_static_ptrs = check_static_ptrs
-               , lf_check_linearity = check_linearity
-               , lf_check_fixed_rep = check_fixed_rep }
-
-    -- In the output of the desugarer, before optimisation,
-    -- we have eta-expanded data constructors with representation-polymorphic
-    -- bindings; so we switch off the representation-polymorphism checks.
-    -- The very simple optimiser will beta-reduce them away.
-    -- See Note [Checking for representation-polymorphic built-ins]
-    -- in GHC.HsToCore.Expr.
-    check_fixed_rep = case pass of
-                        CoreDesugar -> False
-                        _           -> True
-
-    -- See Note [Checking for global Ids]
-    check_globals = case pass of
-                      CoreTidy -> False
-                      CorePrep -> False
-                      _        -> True
-
-    -- See Note [Checking for INLINE loop breakers]
-    check_lbs = case pass of
-                      CoreDesugar    -> False
-                      CoreDesugarOpt -> False
-                      _              -> True
-
-    -- See Note [Checking StaticPtrs]
-    check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
-                      | otherwise = case pass of
-                          CoreDoFloatOutwards _ -> AllowAtTopLevel
-                          CoreTidy              -> RejectEverywhere
-                          CorePrep              -> AllowAtTopLevel
-                          _                     -> AllowAnywhere
-
-    -- See Note [Linting linearity]
-    check_linearity = gopt Opt_DoLinearCoreLinting dflags || (
-                        case pass of
-                          CoreDesugar -> True
-                          _ -> False)
-
     (_, dups) = removeDups compare binders
 
     -- dups_ext checks for names with different uniques
@@ -552,18 +506,16 @@ hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore.
 -}
 
 lintUnfolding :: Bool             -- ^ True <=> is a compulsory unfolding
-              -> DynFlags
+              -> LintConfig
               -> SrcLoc
-              -> VarSet           -- ^ Treat these as in scope
               -> CoreExpr
               -> Maybe (Bag SDoc) -- Nothing => OK
 
-lintUnfolding is_compulsory dflags locn var_set expr
+lintUnfolding is_compulsory cfg locn expr
   | isEmptyBag errs = Nothing
   | otherwise       = Just errs
   where
-    vars = nonDetEltsUniqSet var_set
-    (_warns, errs) = initL dflags (defaultLintFlags dflags) vars $
+    (_warns, errs) = initL cfg $
                      if is_compulsory
                        -- See Note [Checking for representation polymorphism]
                      then noFixedRuntimeRepChecks linter
@@ -571,16 +523,15 @@ lintUnfolding is_compulsory dflags locn var_set expr
     linter = addLoc (ImportedUnfolding locn) $
              lintCoreExpr expr
 
-lintExpr :: DynFlags
-         -> [Var]               -- Treat these as in scope
+lintExpr :: LintConfig
          -> CoreExpr
          -> Maybe (Bag SDoc)  -- Nothing => OK
 
-lintExpr dflags vars expr
+lintExpr cfg expr
   | isEmptyBag errs = Nothing
   | otherwise       = Just errs
   where
-    (_warns, errs) = initL dflags (defaultLintFlags dflags) vars linter
+    (_warns, errs) = initL cfg linter
     linter = addLoc TopLevelBindings $
              lintCoreExpr expr
 
@@ -2304,7 +2255,7 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
 
      validateCoercion :: PrimRep -> PrimRep -> LintM ()
      validateCoercion rep1 rep2
-       = do { platform <- targetPlatform <$> getDynFlags
+       = do { platform <- getPlatform
             ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)
                          (report "between unboxed and boxed value")
             ; checkWarnL (TyCon.primRepSizeB platform rep1
@@ -2507,13 +2458,13 @@ lintCoercion (HoleCo h)
 -}
 
 lintAxioms :: Logger
-           -> DynFlags
+           -> LintConfig
            -> SDoc -- ^ The source of the linted axioms
            -> [CoAxiom Branched]
            -> IO ()
-lintAxioms logger dflags what axioms =
+lintAxioms logger cfg what axioms =
   displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $
-  initL dflags (defaultLintFlags dflags) [] $
+  initL cfg $
   do { mapM_ lint_axiom axioms
      ; let axiom_groups = groupWith coAxiomTyCon axioms
      ; mapM_ lint_axiom_group axiom_groups }
@@ -2704,10 +2655,12 @@ data LintEnv
                                -- A subset of the InScopeSet in le_subst
                                -- See Note [Join points]
 
-       , le_dynflags :: DynFlags     -- DynamicFlags
        , le_ue_aliases :: NameEnv UsageEnv -- Assigns usage environments to the
                                            -- alias-like binders, as found in
                                            -- non-recursive lets.
+
+       , le_platform   :: Platform         -- ^ Target platform
+       , le_diagOpts   :: DiagOpts         -- ^ Target platform
        }
 
 data LintFlags
@@ -2729,15 +2682,6 @@ data StaticPtrCheck
         -- ^ Reject any 'makeStatic' occurrence.
   deriving Eq
 
-defaultLintFlags :: DynFlags -> LintFlags
-defaultLintFlags dflags = LF { lf_check_global_ids = False
-                             , lf_check_inline_loop_breakers = True
-                             , lf_check_static_ptrs = AllowAnywhere
-                             , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags
-                             , lf_report_unsat_syns = True
-                             , lf_check_fixed_rep = True
-                             }
-
 newtype LintM a =
    LintM { unLintM ::
             LintEnv ->
@@ -2884,8 +2828,8 @@ instance Monad LintM where
 instance MonadFail LintM where
     fail err = failWithL (text err)
 
-instance HasDynFlags LintM where
-  getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs))
+getPlatform :: LintM Platform
+getPlatform = LintM (\ e errs -> (Just (le_platform e), errs))
 
 data LintLocInfo
   = RhsOf Id            -- The variable bound
@@ -2906,26 +2850,33 @@ data LintLocInfo
   | InCo   Coercion     -- Inside a coercion
   | InAxiom (CoAxiom Branched)   -- Inside a CoAxiom
 
-initL :: DynFlags
-      -> LintFlags
-      -> [Var]              -- ^ 'Id's that should be treated as being in scope
+data LintConfig = LintConfig
+  { l_diagOpts   :: !DiagOpts         -- ^ Diagnostics opts
+  , l_platform   :: !Platform         -- ^ Target platform
+  , l_flags      :: !LintFlags        -- ^ Linting the result of this pass
+  , l_vars       :: ![Var]            -- ^ 'Id's that should be treated as being in scope
+  }
+
+initL :: LintConfig
       -> LintM a            -- ^ Action to run
       -> WarnsAndErrs
-initL dflags flags vars m
+initL cfg m
   = case unLintM m env (emptyBag, emptyBag) of
       (Just _, errs) -> errs
       (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs
                              | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++
                                                       "without reporting an error message") empty
   where
-    (tcvs, ids) = partition isTyCoVar vars
-    env = LE { le_flags = flags
+    (tcvs, ids) = partition isTyCoVar $ l_vars cfg
+    env = LE { le_flags = l_flags cfg
              , le_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tcvs))
              , le_ids   = mkVarEnv [(id, (id,idType id)) | id <- ids]
              , le_joins = emptyVarSet
              , le_loc = []
-             , le_dynflags = dflags
-             , le_ue_aliases = emptyNameEnv }
+             , le_ue_aliases = emptyNameEnv
+             , le_platform = l_platform cfg
+             , le_diagOpts = l_diagOpts cfg
+             }
 
 setReportUnsat :: Bool -> LintM a -> LintM a
 -- Switch off lf_report_unsat_syns
@@ -2988,7 +2939,7 @@ addMsg is_error env msgs msg
                           , isGoodSrcSpan span ] of
                []    -> noSrcSpan
                (s:_) -> s
-   !diag_opts = initDiagOpts (le_dynflags env)
+   !diag_opts = le_diagOpts env
    mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag) msg_span
                              (msg $$ context)
 
@@ -3522,15 +3473,8 @@ lintAnnots pname pass guts = {-# SCC "lintAnnots" #-} do
 withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
 withoutAnnots pass guts = do
   -- Remove debug flag from environment.
-  dflags <- getDynFlags
-  let removeFlag env = hscSetFlags (dflags { debugLevel = 0}) env
-      withoutFlag corem =
-          -- TODO: supply tag here as well ?
-        liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
-                                getUniqMask <*> getModule <*>
-                                getVisibleOrphanMods <*>
-                                getPrintUnqualified <*> getSrcSpanM <*>
-                                pure corem
+  -- TODO: supply tag here as well ?
+  let withoutFlag = mapDynFlagsCoreM $ \(!dflags) -> dflags { debugLevel = 0 }
   -- Nuke existing ticks in module.
   -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
   -- them in absence of debugLevel > 0.
@@ -3541,5 +3485,6 @@ withoutAnnots pass guts = do
         NonRec b e -> NonRec b $ nukeTicks e
       nukeAnnotsMod mg@ModGuts{mg_binds=binds}
         = mg{mg_binds = map nukeAnnotsBind binds}
-  -- Perform pass with all changes applied
-  fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts)
+  -- Perform pass with all changes applied. Drop the simple count so it doesn't
+  -- effect the total also
+  dropSimplCount $ withoutFlag $ pass (nukeAnnotsMod guts)
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index 4182be9fb9..4753555221 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -26,10 +26,13 @@ module GHC.Core.Opt.Monad (
     -- * The monad
     CoreM, runCoreM,
 
+    mapDynFlagsCoreM, dropSimplCount,
+
     -- ** Reading from the monad
     getHscEnv, getModule,
     getRuleBase, getExternalRuleBase,
     getDynFlags, getPackageFamInstEnv,
+    getInteractiveContext,
     getVisibleOrphanMods, getUniqMask,
     getPrintUnqualified, getSrcSpanM,
 
@@ -73,6 +76,8 @@ import GHC.Data.FastString
 import GHC.Data.IOEnv hiding     ( liftIO, failM, failWithM )
 import qualified GHC.Data.IOEnv  as IOEnv
 
+import GHC.Runtime.Context ( InteractiveContext )
+
 import GHC.Unit.Module
 import GHC.Unit.Module.ModGuts
 import GHC.Unit.External
@@ -728,6 +733,20 @@ getUniqMask = read cr_uniq_mask
 
 -- Convenience accessors for useful fields of HscEnv
 
+-- | Adjust the dyn flags passed to the arugment action
+mapDynFlagsCoreM :: (DynFlags -> DynFlags) -> CoreM a -> CoreM a
+mapDynFlagsCoreM f m = CoreM $ do
+  !e <- getEnv
+  let !e' = e { cr_hsc_env = hscUpdateFlags f $ cr_hsc_env e }
+  liftIO $ runIOEnv e' $! unCoreM m
+
+-- | Drop the single count of the argument action so it doesn't effect
+-- the total.
+dropSimplCount :: CoreM a -> CoreM a
+dropSimplCount m = CoreM $ do
+  (a, _) <- unCoreM m
+  unCoreM $ pure a
+
 instance HasDynFlags CoreM where
     getDynFlags = fmap hsc_dflags getHscEnv
 
@@ -737,6 +756,9 @@ instance HasLogger CoreM where
 instance HasModule CoreM where
     getModule = read cr_module
 
+getInteractiveContext :: CoreM InteractiveContext
+getInteractiveContext = hsc_IC <$> getHscEnv
+
 getPackageFamInstEnv :: CoreM PackageFamInstEnv
 getPackageFamInstEnv = eps_fam_inst_env <$> get_eps
 
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 93e113cd89..589441bffe 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -13,6 +13,7 @@ import GHC.Prelude
 import GHC.Driver.Session
 import GHC.Driver.Plugins ( withPlugins, installCoreToDos )
 import GHC.Driver.Env
+import GHC.Driver.Config.Core.Lint ( endPass, lintPassResult )
 import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts )
 import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts )
 import GHC.Driver.Config.Core.Rules ( initRuleOpts )
@@ -27,8 +28,7 @@ import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr )
 import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
 import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize )
 import GHC.Core.Utils   ( mkTicks, stripTicksTop, dumpIdInfoOfProgram )
-import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,
-                          lintAnnots )
+import GHC.Core.Lint    ( dumpPassResult, lintAnnots )
 import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplImpRules )
 import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding )
 import GHC.Core.Opt.Simplify.Env
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 045d580a2a..e92888ec33 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -22,6 +22,7 @@ import GHC.Prelude
 import GHC.Platform
 
 import GHC.Driver.Session
+import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )
 import GHC.Driver.Env
 import GHC.Driver.Ppr
 
@@ -37,7 +38,6 @@ import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
 import GHC.Core.Utils
 import GHC.Core.Opt.Arity
 import GHC.Core.Opt.Monad ( CoreToDo(..) )
-import GHC.Core.Lint    ( endPassIO )
 import GHC.Core
 import GHC.Core.Make hiding( FloatBind(..) )   -- We use our own FloatBind here
 import GHC.Core.Type
@@ -253,7 +253,7 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
                       floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 
-    endPassIO hsc_env alwaysQualify CorePrep binds_out []
+    endPassHscEnvIO hsc_env alwaysQualify CorePrep binds_out []
     return binds_out
   where
     dflags = hsc_dflags hsc_env
diff --git a/compiler/GHC/Driver/Config/Core/Lint.hs b/compiler/GHC/Driver/Config/Core/Lint.hs
new file mode 100644
index 0000000000..d7d26a9718
--- /dev/null
+++ b/compiler/GHC/Driver/Config/Core/Lint.hs
@@ -0,0 +1,167 @@
+module GHC.Driver.Config.Core.Lint
+  ( endPass
+  , endPassHscEnvIO
+  , lintPassResult
+  , lintCoreBindings
+  , lintInteractiveExpr
+  , initLintPassResultConfig
+  , initLintConfig
+  ) where
+
+import GHC.Prelude
+
+import qualified GHC.LanguageExtensions as LangExt
+
+import GHC.Driver.Env
+import GHC.Driver.Session
+import GHC.Driver.Config.Diagnostic
+
+import GHC.Core
+import GHC.Core.Ppr
+import GHC.Core.Opt.Monad
+import GHC.Core.Coercion
+
+import GHC.Core.Lint
+
+import GHC.Runtime.Context
+
+import GHC.Data.Bag
+
+import GHC.Utils.Logger
+import GHC.Utils.Outputable as Outputable
+
+{-
+These functions are not CoreM monad stuff, but they probably ought to
+be, and it makes a convenient place for them.  They print out stuff
+before and after core passes, and do Core Lint when necessary.
+-}
+
+endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
+endPass pass binds rules
+  = do { logger <- getLogger
+       ; m_ic <- getInteractiveContext
+       ; dflags <- getDynFlags
+       ; let dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags)
+       ; print_unqual <- getPrintUnqualified
+       ; liftIO $ endPassIO logger
+           (initLintPassResultConfig m_ic dflags)
+           dump_core_sizes (gopt Opt_DoCoreLinting dflags)
+           print_unqual pass binds rules
+       }
+
+endPassHscEnvIO :: HscEnv -> PrintUnqualified
+          -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
+endPassHscEnvIO hsc_env print_unqual pass binds rules
+  = do { let dflags  = hsc_dflags hsc_env
+       ; let dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags)
+       ; endPassIO
+           (hsc_logger hsc_env)
+           (initLintPassResultConfig (hsc_IC hsc_env) dflags)
+           dump_core_sizes (gopt Opt_DoCoreLinting dflags)
+           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
+  = lintCoreBindings' $ LintConfig
+      { l_diagOpts = initDiagOpts dflags
+      , l_platform = targetPlatform dflags
+      , l_flags    = perPassFlags dflags coreToDo
+      , 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
+
+initLintPassResultConfig :: InteractiveContext -> DynFlags -> LintPassResultConfig
+initLintPassResultConfig ic dflags = LintPassResultConfig
+  { endPass_diagOpts      = initDiagOpts dflags
+  , endPass_platform      = targetPlatform dflags
+  , endPass_makeLinkFlags = perPassFlags dflags
+  , endPass_localsInScope = interactiveInScope ic
+  }
+
+perPassFlags :: DynFlags -> CoreToDo -> LintFlags
+perPassFlags dflags pass
+  = (defaultLintFlags dflags)
+               { lf_check_global_ids = check_globals
+               , lf_check_inline_loop_breakers = check_lbs
+               , lf_check_static_ptrs = check_static_ptrs
+               , lf_check_linearity = check_linearity
+               , lf_check_fixed_rep = check_fixed_rep }
+  where
+    -- In the output of the desugarer, before optimisation,
+    -- we have eta-expanded data constructors with representation-polymorphic
+    -- bindings; so we switch off the representation-polymorphism checks.
+    -- The very simple optimiser will beta-reduce them away.
+    -- See Note [Checking for representation-polymorphic built-ins]
+    -- in GHC.HsToCore.Expr.
+    check_fixed_rep = case pass of
+                        CoreDesugar -> False
+                        _           -> True
+
+    -- See Note [Checking for global Ids]
+    check_globals = case pass of
+                      CoreTidy -> False
+                      CorePrep -> False
+                      _        -> True
+
+    -- See Note [Checking for INLINE loop breakers]
+    check_lbs = case pass of
+                      CoreDesugar    -> False
+                      CoreDesugarOpt -> False
+                      _              -> True
+
+    -- See Note [Checking StaticPtrs]
+    check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
+                      | otherwise = case pass of
+                          CoreDoFloatOutwards _ -> AllowAtTopLevel
+                          CoreTidy              -> RejectEverywhere
+                          CorePrep              -> AllowAtTopLevel
+                          _                     -> AllowAnywhere
+
+    -- See Note [Linting linearity]
+    check_linearity = gopt Opt_DoLinearCoreLinting dflags || (
+                        case pass of
+                          CoreDesugar -> True
+                          _ -> False)
+
+initLintConfig :: DynFlags -> [Var] -> LintConfig
+initLintConfig dflags vars =LintConfig
+  { l_diagOpts = initDiagOpts dflags
+  , l_platform = targetPlatform dflags
+  , l_flags    = defaultLintFlags dflags
+  , l_vars     = vars
+  }
+
+defaultLintFlags :: DynFlags -> LintFlags
+defaultLintFlags dflags = LF { lf_check_global_ids = False
+                             , lf_check_inline_loop_breakers = True
+                             , lf_check_static_ptrs = AllowAnywhere
+                             , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags
+                             , lf_report_unsat_syns = True
+                             , lf_check_fixed_rep = True
+                             }
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 36dcf24237..7db9b62331 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -112,6 +112,7 @@ import GHC.Driver.Errors
 import GHC.Driver.Errors.Types
 import GHC.Driver.CodeOutput
 import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig)
+import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO, lintInteractiveExpr )
 import GHC.Driver.Config.Logger   (initLogFlags)
 import GHC.Driver.Config.Parser   (initParserOpts)
 import GHC.Driver.Config.Stg.Ppr  (initStgPprOpts)
@@ -155,7 +156,6 @@ import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )
 import GHC.Core
 import GHC.Core.Tidy           ( tidyExpr )
 import GHC.Core.Type           ( Type, Kind )
-import GHC.Core.Lint           ( lintInteractiveExpr, endPassIO )
 import GHC.Core.Multiplicity
 import GHC.Core.Utils          ( exprType )
 import GHC.Core.ConLike
@@ -2281,7 +2281,7 @@ hscTidy hsc_env guts = do
   let all_tidy_binds = cg_binds cgguts
   let print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) (mg_rdr_env guts)
 
-  endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
+  endPassHscEnvIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
 
   -- If the endPass didn't print the rules, but ddump-rules is
   -- on, print now
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 6fec5e6bfe..7a21bcb391 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -20,6 +20,7 @@ import GHC.Prelude
 
 import GHC.Driver.Session
 import GHC.Driver.Config
+import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )
 import GHC.Driver.Config.HsToCore.Ticks
 import GHC.Driver.Config.HsToCore.Usage
 import GHC.Driver.Env
@@ -55,7 +56,6 @@ import GHC.Core.DataCon ( dataConWrapId )
 import GHC.Core.Make
 import GHC.Core.Rules
 import GHC.Core.Opt.Monad ( CoreToDo(..) )
-import GHC.Core.Lint     ( endPassIO )
 import GHC.Core.Ppr
 
 import GHC.Builtin.Names
@@ -211,7 +211,7 @@ deSugar hsc_env
         -- You might think it doesn't matter, but the simplifier brings all top-level
         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
-        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
+        ; endPassHscEnvIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
         ; let simpl_opts = initSimpleOpts dflags
         ; let (ds_binds, ds_rules_for_imps, occ_anald_binds)
                 = simpleOptPgm simpl_opts mod final_pgm rules_for_imps
@@ -220,7 +220,7 @@ deSugar hsc_env
         ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"
             FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps )
 
-        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
+        ; endPassHscEnvIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
 
         ; let used_names = mkUsedNames tcg_env
               pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 407f7b1980..8c8f9e5802 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -29,6 +29,7 @@ import GHC.Prelude
 
 import GHC.Driver.Env
 import GHC.Driver.Session
+import GHC.Driver.Config.Core.Lint ( initLintConfig )
 
 import GHC.Builtin.Types.Literals(typeNatCoAxiomRules)
 import GHC.Builtin.Types
@@ -94,6 +95,7 @@ import GHC.Types.SrcLoc
 import GHC.Types.TypeEnv
 import GHC.Types.Unique.FM
 import GHC.Types.Unique.DSet ( mkUniqDSet )
+import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
 import GHC.Types.Unique.Supply
 import GHC.Types.Literal
 import GHC.Types.Var as Var
@@ -1224,7 +1226,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
                                         (nonDetEltsUFM $ if_id_env lcl_env) ++
                                         bndrs' ++
                                         exprsFreeIdsList args')
-                      ; case lintExpr dflags in_scope rhs' of
+                      ; case lintExpr (initLintConfig dflags in_scope) rhs' of
                           Nothing   -> return ()
                           Just errs -> do
                             logger <- getLogger
@@ -1780,10 +1782,10 @@ tcUnfoldingRhs is_compulsory toplvl name expr
     -- See Note [Linting Unfoldings from Interfaces] in GHC.Core.Lint
     when (isTopLevel toplvl) $
       whenGOptM Opt_DoCoreLinting $ do
-        in_scope <- get_in_scope
+        in_scope <- nonDetEltsUniqSet <$> get_in_scope
         dflags   <- getDynFlags
         logger   <- getLogger
-        case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of
+        case lintUnfolding is_compulsory (initLintConfig dflags in_scope) noSrcLoc core_expr' of
           Nothing   -> return ()
           Just errs -> liftIO $
             displayLintResults logger False doc
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 56c2b1b8a4..577fc4407c 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -102,6 +102,7 @@ import GHC.Prelude
 import GHC.Platform
 
 import GHC.Driver.Env
+import GHC.Driver.Config.Core.Lint
 import GHC.Driver.Session
 import {-# SOURCE #-} GHC.Driver.Hooks
 
@@ -1821,7 +1822,8 @@ getRoleAnnots bndrs role_env
 -- axioms, but should check other aspects, too.
 lintGblEnv :: Logger -> DynFlags -> TcGblEnv -> TcM ()
 lintGblEnv logger dflags tcg_env =
-  liftIO $ lintAxioms logger dflags (text "TcGblEnv axioms") axioms
+  -- TODO empty list means no extra in scope from GHCi, is this correct?
+  liftIO $ lintAxioms logger (initLintConfig dflags []) (text "TcGblEnv axioms") axioms
   where
     axioms = typeEnvCoAxioms (tcg_type_env tcg_env)
 
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 36c05ac38e..2bc5acba4f 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -397,6 +397,7 @@ Library
         GHC.Driver.Config.Cmm.Parser
         GHC.Driver.Config.CmmToAsm
         GHC.Driver.Config.CmmToLlvm
+        GHC.Driver.Config.Core.Lint
         GHC.Driver.Config.Core.Opt.Arity
         GHC.Driver.Config.Core.Opt.LiberateCase
         GHC.Driver.Config.Core.Opt.WorkWrap
diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs
index 7f51426823..462bdd144d 100644
--- a/testsuite/tests/callarity/unittest/CallArity1.hs
+++ b/testsuite/tests/callarity/unittest/CallArity1.hs
@@ -8,6 +8,7 @@ import GHC.Core.Make
 import GHC.Core.Opt.CallArity (callArityRHS)
 import GHC.Types.Id.Make
 import GHC.SysTools
+import GHC.Driver.Config.Core.Lint
 import GHC.Driver.Session
 import GHC.Utils.Error
 import GHC.Utils.Outputable as Outputable
@@ -172,7 +173,7 @@ main = do
         dflags <- getSessionDynFlags
         logger <- getLogger
         liftIO $ forM_ exprs $ \(n,e) -> do
-            case lintExpr dflags [f,scrutf,scruta] e of
+            case lintExpr (initLintConfig dflags [f,scrutf,scruta]) e of
                 Just errs -> putMsg logger (pprMessageBag errs $$ text "in" <+> text n)
                 Nothing -> return ()
             putMsg logger (text n Outputable.<> char ':')
diff --git a/testsuite/tests/corelint/LintEtaExpand.hs b/testsuite/tests/corelint/LintEtaExpand.hs
index 1f3d7a540b..922a611ffd 100644
--- a/testsuite/tests/corelint/LintEtaExpand.hs
+++ b/testsuite/tests/corelint/LintEtaExpand.hs
@@ -40,6 +40,7 @@ import GHC.Core.Lint
 import GHC.Core.Type
   ( mkVisFunTyMany )
 
+import GHC.Driver.Config.Core.Lint
 import GHC.Driver.Session
   ( GeneralFlag(Opt_SuppressUniques), gopt_set )
 
@@ -90,6 +91,6 @@ main = do
     logger <- getLogger
     liftIO do
       forM_ test_exprs \ ( test_name, expr ) ->
-        forM_ ( lintExpr dflags in_scope expr ) \ errs ->
+        forM_ ( lintExpr (initLintConfig dflags in_scope) expr ) \ errs ->
           putMsg logger
             ( pprMessageBag errs $$ text "in" <+> text test_name )
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index 562b0f2e9d..0c7d753be6 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -89,6 +89,7 @@ GHC.Data.TrieMap
 GHC.Driver.Backend
 GHC.Driver.Backend.Internal
 GHC.Driver.CmdLine
+GHC.Driver.Config.Core.Lint
 GHC.Driver.Config.Diagnostic
 GHC.Driver.Config.Logger
 GHC.Driver.Env
diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout
index e448875858..30267860d8 100644
--- a/testsuite/tests/count-deps/CountDepsParser.stdout
+++ b/testsuite/tests/count-deps/CountDepsParser.stdout
@@ -90,6 +90,7 @@ GHC.Driver.Backend
 GHC.Driver.Backend.Internal
 GHC.Driver.Backpack.Syntax
 GHC.Driver.CmdLine
+GHC.Driver.Config.Core.Lint
 GHC.Driver.Config.Diagnostic
 GHC.Driver.Config.Logger
 GHC.Driver.Env