module GHC.Driver.Config.Core.Lint
( endPass
, endPassHscEnvIO
, lintCoreBindings
, initEndPassConfig
, 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.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.Types.Basic ( CompilerPhase(..) )
import GHC.Utils.Outputable as Outputable
endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
endPass CoreToDo
pass CoreProgram
binds [CoreRule]
rules
= do { HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
; NamePprCtx
name_ppr_ctx <- CoreM NamePprCtx
getNamePprCtx
; IO () -> CoreM ()
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ HscEnv
-> NamePprCtx -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
endPassHscEnvIO HscEnv
hsc_env
NamePprCtx
name_ppr_ctx CoreToDo
pass CoreProgram
binds [CoreRule]
rules
}
endPassHscEnvIO :: HscEnv -> NamePprCtx
-> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
endPassHscEnvIO :: HscEnv
-> NamePprCtx -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
endPassHscEnvIO HscEnv
hsc_env NamePprCtx
name_ppr_ctx CoreToDo
pass CoreProgram
binds [CoreRule]
rules
= do { let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
; Logger -> EndPassConfig -> CoreProgram -> [CoreRule] -> IO ()
endPassIO
(HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
(DynFlags -> [Var] -> NamePprCtx -> CoreToDo -> EndPassConfig
initEndPassConfig DynFlags
dflags (InteractiveContext -> [Var]
interactiveInScope (InteractiveContext -> [Var]) -> InteractiveContext -> [Var]
forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) NamePprCtx
name_ppr_ctx CoreToDo
pass)
CoreProgram
binds [CoreRule]
rules
}
lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
lintCoreBindings DynFlags
dflags CoreToDo
coreToDo [Var]
vars
= LintConfig -> CoreProgram -> WarnsAndErrs
lintCoreBindings' (LintConfig -> CoreProgram -> WarnsAndErrs)
-> LintConfig -> CoreProgram -> WarnsAndErrs
forall a b. (a -> b) -> a -> b
$ LintConfig
{ l_diagOpts :: DiagOpts
l_diagOpts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
, l_platform :: Platform
l_platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
, l_flags :: LintFlags
l_flags = DynFlags -> CoreToDo -> LintFlags
perPassFlags DynFlags
dflags CoreToDo
coreToDo
, l_vars :: [Var]
l_vars = [Var]
vars
}
initEndPassConfig :: DynFlags -> [Var] -> NamePprCtx -> CoreToDo -> EndPassConfig
initEndPassConfig :: DynFlags -> [Var] -> NamePprCtx -> CoreToDo -> EndPassConfig
initEndPassConfig DynFlags
dflags [Var]
extra_vars NamePprCtx
name_ppr_ctx CoreToDo
pass = EndPassConfig
{ ep_dumpCoreSizes :: Bool
ep_dumpCoreSizes = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressCoreSizes DynFlags
dflags)
, ep_lintPassResult :: Maybe LintPassResultConfig
ep_lintPassResult = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoCoreLinting DynFlags
dflags
then LintPassResultConfig -> Maybe LintPassResultConfig
forall a. a -> Maybe a
Just (LintPassResultConfig -> Maybe LintPassResultConfig)
-> LintPassResultConfig -> Maybe LintPassResultConfig
forall a b. (a -> b) -> a -> b
$ DynFlags -> [Var] -> CoreToDo -> LintPassResultConfig
initLintPassResultConfig DynFlags
dflags [Var]
extra_vars CoreToDo
pass
else Maybe LintPassResultConfig
forall a. Maybe a
Nothing
, ep_namePprCtx :: NamePprCtx
ep_namePprCtx = NamePprCtx
name_ppr_ctx
, ep_dumpFlag :: Maybe DumpFlag
ep_dumpFlag = CoreToDo -> Maybe DumpFlag
coreDumpFlag CoreToDo
pass
, ep_prettyPass :: SDoc
ep_prettyPass = CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass
, ep_passDetails :: SDoc
ep_passDetails = CoreToDo -> SDoc
pprPassDetails CoreToDo
pass
}
coreDumpFlag :: CoreToDo -> Maybe DumpFlag
coreDumpFlag :: CoreToDo -> Maybe DumpFlag
coreDumpFlag (CoreDoSimplify {}) = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_verbose_core2core
coreDumpFlag (CoreDoPluginPass {}) = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_verbose_core2core
coreDumpFlag CoreToDo
CoreDoFloatInwards = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_verbose_core2core
coreDumpFlag (CoreDoFloatOutwards {}) = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_verbose_core2core
coreDumpFlag CoreToDo
CoreLiberateCase = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_verbose_core2core
coreDumpFlag CoreToDo
CoreDoStaticArgs = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_verbose_core2core
coreDumpFlag CoreToDo
CoreDoCallArity = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_call_arity
coreDumpFlag CoreToDo
CoreDoExitify = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_exitify
coreDumpFlag (CoreDoDemand {}) = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_stranal
coreDumpFlag CoreToDo
CoreDoCpr = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_cpranal
coreDumpFlag CoreToDo
CoreDoWorkerWrapper = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_worker_wrapper
coreDumpFlag CoreToDo
CoreDoSpecialising = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_spec
coreDumpFlag CoreToDo
CoreDoSpecConstr = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_spec
coreDumpFlag CoreToDo
CoreCSE = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_cse
coreDumpFlag CoreToDo
CoreDesugar = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_ds_preopt
coreDumpFlag CoreToDo
CoreDesugarOpt = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_ds
coreDumpFlag CoreToDo
CoreTidy = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_simpl
coreDumpFlag CoreToDo
CorePrep = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_prep
coreDumpFlag CoreToDo
CoreAddCallerCcs = Maybe DumpFlag
forall a. Maybe a
Nothing
coreDumpFlag CoreToDo
CoreAddLateCcs = Maybe DumpFlag
forall a. Maybe a
Nothing
coreDumpFlag CoreToDo
CoreDoPrintCore = Maybe DumpFlag
forall a. Maybe a
Nothing
coreDumpFlag (CoreDoRuleCheck {}) = Maybe DumpFlag
forall a. Maybe a
Nothing
coreDumpFlag CoreToDo
CoreDoNothing = Maybe DumpFlag
forall a. Maybe a
Nothing
coreDumpFlag (CoreDoPasses {}) = Maybe DumpFlag
forall a. Maybe a
Nothing
initLintPassResultConfig :: DynFlags -> [Var] -> CoreToDo -> LintPassResultConfig
initLintPassResultConfig :: DynFlags -> [Var] -> CoreToDo -> LintPassResultConfig
initLintPassResultConfig DynFlags
dflags [Var]
extra_vars CoreToDo
pass = LintPassResultConfig
{ lpr_diagOpts :: DiagOpts
lpr_diagOpts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
, lpr_platform :: Platform
lpr_platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
, lpr_makeLintFlags :: LintFlags
lpr_makeLintFlags = DynFlags -> CoreToDo -> LintFlags
perPassFlags DynFlags
dflags CoreToDo
pass
, lpr_showLintWarnings :: Bool
lpr_showLintWarnings = CoreToDo -> Bool
showLintWarnings CoreToDo
pass
, lpr_passPpr :: SDoc
lpr_passPpr = CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass
, lpr_localsInScope :: [Var]
lpr_localsInScope = [Var]
extra_vars
}
showLintWarnings :: CoreToDo -> Bool
showLintWarnings :: CoreToDo -> Bool
showLintWarnings (CoreDoSimplify SimplifyOpts
cfg) = case SimplMode -> CompilerPhase
sm_phase (SimplifyOpts -> SimplMode
so_mode SimplifyOpts
cfg) of
CompilerPhase
InitialPhase -> Bool
False
CompilerPhase
_ -> Bool
True
showLintWarnings CoreToDo
_ = Bool
True
perPassFlags :: DynFlags -> CoreToDo -> LintFlags
perPassFlags :: DynFlags -> CoreToDo -> LintFlags
perPassFlags DynFlags
dflags CoreToDo
pass
= (DynFlags -> LintFlags
defaultLintFlags DynFlags
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
check_fixed_rep :: Bool
check_fixed_rep = case CoreToDo
pass of
CoreToDo
CoreDesugar -> Bool
False
CoreToDo
_ -> Bool
True
check_globals :: Bool
check_globals = case CoreToDo
pass of
CoreToDo
CoreTidy -> Bool
False
CoreToDo
CorePrep -> Bool
False
CoreToDo
_ -> Bool
True
check_lbs :: Bool
check_lbs = case CoreToDo
pass of
CoreToDo
CoreDesugar -> Bool
False
CoreToDo
CoreDesugarOpt -> Bool
False
CoreToDo
_ -> Bool
True
check_static_ptrs :: StaticPtrCheck
check_static_ptrs | Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.StaticPointers DynFlags
dflags) = StaticPtrCheck
AllowAnywhere
| Bool
otherwise = case CoreToDo
pass of
CoreDoFloatOutwards FloatOutSwitches
_ -> StaticPtrCheck
AllowAtTopLevel
CoreToDo
CoreTidy -> StaticPtrCheck
RejectEverywhere
CoreToDo
CorePrep -> StaticPtrCheck
AllowAtTopLevel
CoreToDo
_ -> StaticPtrCheck
AllowAnywhere
check_linearity :: Bool
check_linearity = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLinearCoreLinting DynFlags
dflags Bool -> Bool -> Bool
|| (
case CoreToDo
pass of
CoreToDo
CoreDesugar -> Bool
True
CoreToDo
_ -> Bool
False)
initLintConfig :: DynFlags -> [Var] -> LintConfig
initLintConfig :: DynFlags -> [Var] -> LintConfig
initLintConfig DynFlags
dflags [Var]
vars =LintConfig
{ l_diagOpts :: DiagOpts
l_diagOpts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
, l_platform :: Platform
l_platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
, l_flags :: LintFlags
l_flags = DynFlags -> LintFlags
defaultLintFlags DynFlags
dflags
, l_vars :: [Var]
l_vars = [Var]
vars
}
defaultLintFlags :: DynFlags -> LintFlags
defaultLintFlags :: DynFlags -> LintFlags
defaultLintFlags DynFlags
dflags = LF { lf_check_global_ids :: Bool
lf_check_global_ids = Bool
False
, lf_check_inline_loop_breakers :: Bool
lf_check_inline_loop_breakers = Bool
True
, lf_check_static_ptrs :: StaticPtrCheck
lf_check_static_ptrs = StaticPtrCheck
AllowAnywhere
, lf_check_linearity :: Bool
lf_check_linearity = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLinearCoreLinting DynFlags
dflags
, lf_report_unsat_syns :: Bool
lf_report_unsat_syns = Bool
True
, lf_check_fixed_rep :: Bool
lf_check_fixed_rep = Bool
True
}