summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Core/Lint.hs229
-rw-r--r--compiler/GHC/Core/Opt/Monad.hs22
-rw-r--r--compiler/GHC/Core/Opt/Pipeline.hs4
-rw-r--r--compiler/GHC/CoreToStg/Prep.hs4
-rw-r--r--compiler/GHC/Driver/Config/Core/Lint.hs167
-rw-r--r--compiler/GHC/Driver/Main.hs4
-rw-r--r--compiler/GHC/HsToCore.hs6
-rw-r--r--compiler/GHC/IfaceToCore.hs8
-rw-r--r--compiler/GHC/Tc/Types.hs4
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--testsuite/tests/callarity/unittest/CallArity1.hs3
-rw-r--r--testsuite/tests/corelint/LintEtaExpand.hs3
-rw-r--r--testsuite/tests/count-deps/CountDepsAst.stdout1
-rw-r--r--testsuite/tests/count-deps/CountDepsParser.stdout1
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
View Lorry Controller Status