summaryrefslogtreecommitdiff
path: root/compiler/GHC/Driver
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Driver')
-rw-r--r--compiler/GHC/Driver/Config/Core/Lint.hs98
-rw-r--r--compiler/GHC/Driver/Config/Core/Lint/Interactive.hs35
-rw-r--r--compiler/GHC/Driver/Config/Core/Opt/Simplify.hs92
-rw-r--r--compiler/GHC/Driver/Config/CoreToStg/Prep.hs10
-rw-r--r--compiler/GHC/Driver/Main.hs28
-rw-r--r--compiler/GHC/Driver/Plugins.hs3
6 files changed, 209 insertions, 57 deletions
diff --git a/compiler/GHC/Driver/Config/Core/Lint.hs b/compiler/GHC/Driver/Config/Core/Lint.hs
index e96aedaf8e..cde05fa8b7 100644
--- a/compiler/GHC/Driver/Config/Core/Lint.hs
+++ b/compiler/GHC/Driver/Config/Core/Lint.hs
@@ -1,9 +1,7 @@
module GHC.Driver.Config.Core.Lint
( endPass
, endPassHscEnvIO
- , lintPassResult
, lintCoreBindings
- , lintInteractiveExpr
, initEndPassConfig
, initLintPassResultConfig
, initLintConfig
@@ -18,15 +16,15 @@ import GHC.Driver.Session
import GHC.Driver.Config.Diagnostic
import GHC.Core
-import GHC.Core.Ppr
+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.Core.Lint
-
-import GHC.Runtime.Context
-
-import GHC.Data.Bag
+import GHC.Types.Basic ( CompilerPhase(..) )
import GHC.Utils.Outputable as Outputable
@@ -50,22 +48,10 @@ endPassHscEnvIO hsc_env print_unqual pass binds rules
= do { let dflags = hsc_dflags hsc_env
; endPassIO
(hsc_logger hsc_env)
- (initEndPassConfig (hsc_IC hsc_env) dflags)
- print_unqual pass binds rules
+ (initEndPassConfig dflags (interactiveInScope $ hsc_IC hsc_env) 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
@@ -76,35 +62,63 @@ lintCoreBindings dflags coreToDo vars -- binds
, 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
-
-initEndPassConfig :: InteractiveContext -> DynFlags -> EndPassConfig
-initEndPassConfig ic dflags = EndPassConfig
+initEndPassConfig :: DynFlags -> [Var] -> PrintUnqualified -> CoreToDo -> EndPassConfig
+initEndPassConfig dflags extra_vars print_unqual pass = EndPassConfig
{ ep_dumpCoreSizes = not (gopt Opt_SuppressCoreSizes dflags)
, ep_lintPassResult = if gopt Opt_DoCoreLinting dflags
- then Just $ initLintPassResultConfig ic dflags
+ then Just $ initLintPassResultConfig dflags extra_vars pass
else Nothing
+ , ep_printUnqual = print_unqual
+ , ep_dumpFlag = coreDumpFlag pass
+ , ep_prettyPass = ppr pass
+ , ep_passDetails = pprPassDetails pass
}
-initLintPassResultConfig :: InteractiveContext -> DynFlags -> LintPassResultConfig
-initLintPassResultConfig ic dflags = LintPassResultConfig
+coreDumpFlag :: CoreToDo -> Maybe DumpFlag
+coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core
+coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
+coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity
+coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify
+coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal
+coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal
+coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
+coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
+coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
+coreDumpFlag CoreCSE = Just Opt_D_dump_cse
+coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt
+coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds
+coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
+coreDumpFlag CorePrep = Just Opt_D_dump_prep
+
+coreDumpFlag CoreAddCallerCcs = Nothing
+coreDumpFlag CoreAddLateCcs = Nothing
+coreDumpFlag CoreDoPrintCore = Nothing
+coreDumpFlag (CoreDoRuleCheck {}) = Nothing
+coreDumpFlag CoreDoNothing = Nothing
+coreDumpFlag (CoreDoPasses {}) = Nothing
+
+initLintPassResultConfig :: DynFlags -> [Var] -> CoreToDo -> LintPassResultConfig
+initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig
{ lpr_diagOpts = initDiagOpts dflags
, lpr_platform = targetPlatform dflags
- , lpr_makeLintFlags = perPassFlags dflags
- , lpr_localsInScope = interactiveInScope ic
+ , lpr_makeLintFlags = perPassFlags dflags pass
+ , lpr_showLintWarnings = showLintWarnings pass
+ , lpr_passPpr = ppr pass
+ , lpr_localsInScope = 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 (CoreDoSimplify cfg) = case sm_phase (so_mode cfg) of
+ InitialPhase -> False
+ _ -> True
+showLintWarnings _ = True
+
perPassFlags :: DynFlags -> CoreToDo -> LintFlags
perPassFlags dflags pass
= (defaultLintFlags dflags)
diff --git a/compiler/GHC/Driver/Config/Core/Lint/Interactive.hs b/compiler/GHC/Driver/Config/Core/Lint/Interactive.hs
new file mode 100644
index 0000000000..3c798ef478
--- /dev/null
+++ b/compiler/GHC/Driver/Config/Core/Lint/Interactive.hs
@@ -0,0 +1,35 @@
+module GHC.Driver.Config.Core.Lint.Interactive
+ ( lintInteractiveExpr
+ ) where
+
+import GHC.Prelude
+
+import GHC.Driver.Env
+import GHC.Driver.Session
+import GHC.Driver.Config.Core.Lint
+
+import GHC.Core
+import GHC.Core.Ppr
+
+import GHC.Core.Lint
+import GHC.Core.Lint.Interactive
+
+--import GHC.Runtime.Context
+
+import GHC.Data.Bag
+
+import GHC.Utils.Outputable as Outputable
+
+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
diff --git a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
new file mode 100644
index 0000000000..b413f2d066
--- /dev/null
+++ b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
@@ -0,0 +1,92 @@
+module GHC.Driver.Config.Core.Opt.Simplify
+ ( initSimplifyExprOpts
+ , initSimplifyOpts
+ , initSimplMode
+ , initGentleSimplMode
+ ) where
+
+import GHC.Prelude
+
+import GHC.Core ( RuleBase )
+import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
+import GHC.Core.Opt.Simplify ( SimplifyExprOpts(..), SimplifyOpts(..) )
+import GHC.Core.Opt.Simplify.Env ( FloatEnable(..), SimplMode(..) )
+import GHC.Core.Opt.Simplify.Monad ( TopEnvConfig(..) )
+
+import GHC.Driver.Config ( initOptCoercionOpts )
+import GHC.Driver.Config.Core.Lint ( initLintPassResultConfig )
+import GHC.Driver.Config.Core.Rules ( initRuleOpts )
+import GHC.Driver.Config.Core.Opt.Arity ( initArityOpts )
+import GHC.Driver.Session ( DynFlags(..), GeneralFlag(..), gopt )
+
+import GHC.Runtime.Context ( InteractiveContext(..) )
+
+import GHC.Types.Basic ( CompilerPhase(..) )
+import GHC.Types.Var ( Var )
+
+initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts
+initSimplifyExprOpts dflags ic = SimplifyExprOpts
+ { se_fam_inst = snd $ ic_instances ic
+ , se_mode = (initSimplMode dflags InitialPhase "GHCi")
+ { sm_inline = False
+ -- Do not do any inlining, in case we expose some
+ -- unboxed tuple stuff that confuses the bytecode
+ -- interpreter
+ }
+ , se_top_env_cfg = TopEnvConfig
+ { te_history_size = historySize dflags
+ , te_tick_factor = simplTickFactor dflags
+ }
+ }
+
+initSimplifyOpts :: DynFlags -> [Var] -> Int -> SimplMode -> RuleBase -> SimplifyOpts
+initSimplifyOpts dflags extra_vars iterations mode rule_base = let
+ -- This is a particularly ugly construction, but we will get rid of it in !8341.
+ opts = SimplifyOpts
+ { so_dump_core_sizes = not $ gopt Opt_SuppressCoreSizes dflags
+ , so_iterations = iterations
+ , so_mode = mode
+ , so_pass_result_cfg = if gopt Opt_DoCoreLinting dflags
+ then Just $ initLintPassResultConfig dflags extra_vars (CoreDoSimplify opts)
+ else Nothing
+ , so_rule_base = rule_base
+ , so_top_env_cfg = TopEnvConfig
+ { te_history_size = historySize dflags
+ , te_tick_factor = simplTickFactor dflags
+ }
+ }
+ in opts
+
+initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode
+initSimplMode dflags phase name = SimplMode
+ { sm_names = [name]
+ , sm_phase = phase
+ , sm_rules = gopt Opt_EnableRewriteRules dflags
+ , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags
+ , sm_cast_swizzle = True
+ , sm_inline = True
+ , sm_uf_opts = unfoldingOpts dflags
+ , sm_case_case = True
+ , sm_pre_inline = gopt Opt_SimplPreInlining dflags
+ , sm_float_enable = floatEnable dflags
+ , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags
+ , sm_arity_opts = initArityOpts dflags
+ , sm_rule_opts = initRuleOpts dflags
+ , sm_case_folding = gopt Opt_CaseFolding dflags
+ , sm_case_merge = gopt Opt_CaseMerge dflags
+ , sm_co_opt_opts = initOptCoercionOpts dflags
+ }
+
+initGentleSimplMode :: DynFlags -> SimplMode
+initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle")
+ { -- Don't do case-of-case transformations.
+ -- This makes full laziness work better
+ sm_case_case = False
+ }
+
+floatEnable :: DynFlags -> FloatEnable
+floatEnable dflags =
+ case (gopt Opt_LocalFloatOut dflags, gopt Opt_LocalFloatOutTopLevel dflags) of
+ (True, True) -> FloatEnabled
+ (True, False)-> FloatNestedOnly
+ (False, _) -> FloatDisabled
diff --git a/compiler/GHC/Driver/Config/CoreToStg/Prep.hs b/compiler/GHC/Driver/Config/CoreToStg/Prep.hs
index a0dab03519..9f2a757457 100644
--- a/compiler/GHC/Driver/Config/CoreToStg/Prep.hs
+++ b/compiler/GHC/Driver/Config/CoreToStg/Prep.hs
@@ -5,11 +5,13 @@ module GHC.Driver.Config.CoreToStg.Prep
import GHC.Prelude
+import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Config.Core.Lint
-import GHC.Runtime.Context ( InteractiveContext )
import GHC.Tc.Utils.Env
+import GHC.Types.Var
+import GHC.Utils.Outputable ( alwaysQualify )
import GHC.CoreToStg.Prep
@@ -25,8 +27,8 @@ initCorePrepConfig hsc_env = do
, cp_convertNumLit = convertNumLit
}
-initCorePrepPgmConfig :: InteractiveContext -> DynFlags -> CorePrepPgmConfig
-initCorePrepPgmConfig ic dflags = CorePrepPgmConfig
- { cpPgm_endPassConfig = initEndPassConfig ic dflags
+initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig
+initCorePrepPgmConfig dflags extra_vars = CorePrepPgmConfig
+ { cpPgm_endPassConfig = initEndPassConfig dflags extra_vars alwaysQualify CorePrep
, cpPgm_generateDebugInfo = needSourceNotes dflags
}
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 237352877a..739ac5b46a 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -113,7 +113,9 @@ 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.Core.Opt.Simplify ( initSimplifyExprOpts )
+import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )
+import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr )
import GHC.Driver.Config.CoreToStg.Prep
import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Config.Parser (initParserOpts)
@@ -156,13 +158,14 @@ import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
import GHC.Core
+import GHC.Core.Lint.Interactive ( interactiveInScope )
import GHC.Core.Tidy ( tidyExpr )
import GHC.Core.Type ( Type, Kind )
import GHC.Core.Multiplicity
import GHC.Core.Utils ( exprType )
import GHC.Core.ConLike
-import GHC.Core.Opt.Monad ( CoreToDo (..))
import GHC.Core.Opt.Pipeline
+import GHC.Core.Opt.Pipeline.Types ( CoreToDo (..))
import GHC.Core.TyCon
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
@@ -1696,7 +1699,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
corePrepPgm
(hsc_logger hsc_env)
cp_cfg
- (initCorePrepPgmConfig (hsc_IC hsc_env) (hsc_dflags hsc_env))
+ (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
this_mod location core_binds data_tycons
----------------- Convert to STG ------------------
@@ -1779,7 +1782,7 @@ hscInteractive hsc_env cgguts location = do
corePrepPgm
(hsc_logger hsc_env)
cp_cfg
- (initCorePrepPgmConfig (hsc_IC hsc_env) (hsc_dflags hsc_env))
+ (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
this_mod location core_binds data_tycons
(stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
@@ -1972,7 +1975,7 @@ myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
stg_binds_with_fvs
<- {-# SCC "Stg2Stg" #-}
- stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode)
+ stg2stg logger (interactiveInScope ictxt) (initStgPipelineOpts dflags for_bytecode)
this_mod stg_binds
putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG
@@ -2126,7 +2129,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
corePrepPgm
(hsc_logger hsc_env)
cp_cfg
- (initCorePrepPgmConfig (hsc_IC hsc_env) (hsc_dflags hsc_env))
+ (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
this_mod iNTERACTIVELoc core_binds data_tycons
(stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
@@ -2340,7 +2343,12 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
= do { {- Simplify it -}
-- Question: should we call SimpleOpt.simpleOptExpr here instead?
-- It is, well, simpler, and does less inlining etc.
- simpl_expr <- simplifyExpr hsc_env ds_expr
+ let dflags = hsc_dflags hsc_env
+ ; let logger = hsc_logger hsc_env
+ ; let ic = hsc_IC hsc_env
+ ; let unit_env = hsc_unit_env hsc_env
+ ; let simplify_expr_opts = initSimplifyExprOpts dflags ic
+ ; simpl_expr <- simplifyExpr logger (ue_eps unit_env) simplify_expr_opts ds_expr
{- Tidy it (temporary, until coreSat does cloning) -}
; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
@@ -2348,7 +2356,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
{- Prepare for codegen -}
; cp_cfg <- initCorePrepConfig hsc_env
; prepd_expr <- corePrepExpr
- (hsc_logger hsc_env) cp_cfg
+ logger cp_cfg
tidy_expr
{- Lint if necessary -}
@@ -2362,8 +2370,8 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
; let ictxt = hsc_IC hsc_env
; (binding_id, stg_expr, _, _) <-
- myCoreToStgExpr (hsc_logger hsc_env)
- (hsc_dflags hsc_env)
+ myCoreToStgExpr logger
+ dflags
ictxt
True
(icInteractiveModule ictxt)
diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs
index 67d8422562..9a5bfefc6f 100644
--- a/compiler/GHC/Driver/Plugins.hs
+++ b/compiler/GHC/Driver/Plugins.hs
@@ -71,7 +71,8 @@ import qualified GHC.Tc.Types
import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports )
import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR )
-import GHC.Core.Opt.Monad ( CoreToDo, CoreM )
+import GHC.Core.Opt.Monad ( CoreM )
+import GHC.Core.Opt.Pipeline.Types ( CoreToDo )
import GHC.Hs
import GHC.Types.Error (Messages)
import GHC.Utils.Fingerprint
View Lorry Controller Status