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.DynFlags
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

{-
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 :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
endPass CoreToDo
pass CoreProgram
binds [CoreRule]
rules
  = do { hsc_env <- CoreM HscEnv
getHscEnv
       ; name_ppr_ctx <- getNamePprCtx
       ; liftIO $ endPassHscEnvIO hsc_env
           name_ppr_ctx pass binds 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
       }

-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
lintCoreBindings DynFlags
dflags CoreToDo
coreToDo [Var]
vars -- binds
  = 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_dump_float_in
coreDumpFlag (CoreDoFloatOutwards {}) = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_float_out
coreDumpFlag CoreToDo
CoreLiberateCase         = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_liberate_case
coreDumpFlag CoreToDo
CoreDoStaticArgs         = DumpFlag -> Maybe DumpFlag
forall a. a -> Maybe a
Just DumpFlag
Opt_D_dump_static_argument_transformation
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_dmdanal
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_constr
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
-- Disable Lint warnings on the first simplifier pass, because
-- there may be some INLINE knots still tied, which is tiresomely noisy
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
    -- 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 [Representation-polymorphism checking built-ins] in GHC.Tc.Gen.Head.
    check_fixed_rep :: Bool
check_fixed_rep = case CoreToDo
pass of
                        CoreToDo
CoreDesugar -> Bool
False
                        CoreToDo
_           -> Bool
True

    -- See Note [Checking for global Ids]
    check_globals :: Bool
check_globals = case CoreToDo
pass of
                      CoreToDo
CoreTidy -> Bool
False
                      CoreToDo
CorePrep -> Bool
False
                      CoreToDo
_        -> Bool
True

    -- See Note [Checking for INLINE loop breakers]
    check_lbs :: Bool
check_lbs = case CoreToDo
pass of
                      CoreToDo
CoreDesugar    -> Bool
False
                      CoreToDo
CoreDesugarOpt -> Bool
False
                      CoreToDo
_              -> Bool
True

    -- See Note [Checking StaticPtrs]
    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

    -- See Note [Linting linearity]
    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
                             }