    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
                                 }