diff options
| author | Dominik Peteler <haskell+gitlab@with-h.at> | 2022-07-04 23:47:16 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-07-22 08:18:40 -0400 |
| commit | 9a3e1f316598f7d5072ed4f94437f759352580a5 (patch) | |
| tree | f9286cb4014b4a1ca9d67afff241b54ca1340a9d | |
| parent | 81d65f7f358fdbd1d13b89c43fc4cbe3ac82d24b (diff) | |
| download | haskell-9a3e1f316598f7d5072ed4f94437f759352580a5.tar.gz | |
Refactored Simplify pass
* Removed references to driver from GHC.Core.LateCC, GHC.Core.Simplify
namespace and GHC.Core.Opt.Stats.
Also removed services from configuration records.
* Renamed GHC.Core.Opt.Simplify to GHC.Core.Opt.Simplify.Iteration.
* Inlined `simplifyPgm` and renamed `simplifyPgmIO` to `simplifyPgm`
and moved the Simplify driver to GHC.Core.Opt.Simplify.
* Moved `SimplMode` and `FloatEnable` to GHC.Core.Opt.Simplify.Env.
* Added a configuration record `TopEnvConfig` for the `SimplTopEnv` environment
in GHC.Core.Opt.Simplify.Monad.
* Added `SimplifyOpts` and `SimplifyExprOpts`. Provide initialization functions
for those in a new module GHC.Driver.Config.Core.Opt.Simplify.
Also added initialization functions for `SimplMode` to that module.
* Moved `CoreToDo` and friends to a new module GHC.Core.Pipeline.Types
and the counting types and functions (`SimplCount` and `Tick`) to new
module GHC.Core.Opt.Stats.
* Added getter functions for the fields of `SimplMode`. The pedantic bottoms
option and the platform are retrieved from the ArityOpts and RuleOpts and the
getter functions allow us to retrieve values from `SpecEnv` without the
knowledge where the data is stored exactly.
* Moved the coercion optimization options from the top environment to
`SimplMode`. This way the values left in the top environment are those
dealing with monadic functionality, namely logging, IO related stuff and
counting. Added a note "The environments of the Simplify pass".
* Removed `CoreToDo` from GHC.Core.Lint and GHC.CoreToStg.Prep and got rid of
`CoreDoSimplify`. Pass `SimplifyOpts` in the `CoreToDo` type instead.
* Prep work before removing `InteractiveContext` from `HscEnv`.
29 files changed, 5925 insertions, 5667 deletions
diff --git a/compiler/GHC/Core/LateCC.hs b/compiler/GHC/Core/LateCC.hs index 634eabc4f6..2b4f810441 100644 --- a/compiler/GHC/Core/LateCC.hs +++ b/compiler/GHC/Core/LateCC.hs @@ -11,7 +11,6 @@ import GHC.Utils.Monad.State.Strict import Control.Monad import GHC.Prelude -import GHC.Driver.Session import GHC.Types.CostCentre import GHC.Types.CostCentre.State import GHC.Types.Name hiding (varName) @@ -21,22 +20,17 @@ import GHC.Types.Var import GHC.Unit.Types import GHC.Data.FastString import GHC.Core -import GHC.Core.Opt.Monad import GHC.Types.Id import GHC.Core.Utils (mkTick) -addLateCostCentres :: ModGuts -> CoreM ModGuts -addLateCostCentres guts = do - dflags <- getDynFlags - let env :: Env - env = Env - { thisModule = mg_module guts - , ccState = newCostCentreState - , dflags = dflags - } - let guts' = guts { mg_binds = doCoreProgram env (mg_binds guts) - } - return guts' +addLateCostCentres :: Bool -> ModGuts -> ModGuts +addLateCostCentres prof_count_entries guts = let + env = Env + { thisModule = mg_module guts + , ccState = newCostCentreState + , countEntries = prof_count_entries + } + in guts { mg_binds = doCoreProgram env (mg_binds guts) } doCoreProgram :: Env -> CoreProgram -> CoreProgram doCoreProgram env binds = flip evalState newCostCentreState $ do @@ -54,7 +48,7 @@ doBndr env bndr rhs = do let name = idName bndr name_loc = nameSrcSpan name cc_name = getOccFS name - count = gopt Opt_ProfCountEntries (dflags env) + count = countEntries env cc_flavour <- getCCExprFlavour cc_name let cc_mod = thisModule env bndrCC = NormalCC cc_flavour cc_name cc_mod name_loc @@ -70,8 +64,8 @@ getCCIndex' :: FastString -> M CostCentreIndex getCCIndex' name = state (getCCIndex name) data Env = Env - { thisModule :: Module - , dflags :: DynFlags - , ccState :: CostCentreState + { thisModule :: Module + , countEntries :: Bool + , ccState :: CostCentreState } diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 00636ec444..c6f4fdf42f 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -19,11 +19,9 @@ module GHC.Core.Lint ( WarnsAndErrs, lintCoreBindings', lintUnfolding, - lintPassResult', lintExpr, + lintPassResult, lintExpr, lintAnnots, lintAxioms, - interactiveInScope, - -- ** Debug output EndPassConfig (..), endPassIO, @@ -37,13 +35,11 @@ import GHC.Driver.Session import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree ) import GHC.Unit.Module.ModGuts import GHC.Platform -import GHC.Runtime.Context import GHC.Core import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Stats ( coreBindsStats ) -import GHC.Core.Opt.Monad import GHC.Core.DataCon import GHC.Core.Ppr import GHC.Core.Coercion @@ -57,10 +53,11 @@ import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars ) import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify -import GHC.Core.InstEnv ( instanceDFunId, instEnvElts ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Opt.Arity ( typeArity ) +import GHC.Core.Opt.Monad + import GHC.Types.Literal import GHC.Types.Var as Var import GHC.Types.Var.Env @@ -74,7 +71,6 @@ import GHC.Types.Tickish import GHC.Types.RepType import GHC.Types.Basic import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv ) -import GHC.Types.TypeEnv import GHC.Builtin.Names import GHC.Builtin.Types.Prim @@ -283,24 +279,30 @@ data EndPassConfig = EndPassConfig , ep_lintPassResult :: !(Maybe LintPassResultConfig) -- ^ Whether we should lint the result of this pass. + + , ep_printUnqual :: !PrintUnqualified + + , ep_dumpFlag :: !(Maybe DumpFlag) + + , ep_prettyPass :: !SDoc + + , ep_passDetails :: !SDoc } endPassIO :: Logger -> EndPassConfig - -> PrintUnqualified - -> CoreToDo -> CoreProgram -> [CoreRule] + -> CoreProgram -> [CoreRule] -> IO () -- Used by the IO-is CorePrep too -endPassIO logger cfg print_unqual - pass binds rules - = do { dumpPassResult logger (ep_dumpCoreSizes cfg) print_unqual mb_flag - (renderWithContext defaultSDocContext (ppr pass)) - (pprPassDetails pass) binds rules +endPassIO logger cfg binds rules + = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_printUnqual cfg) mb_flag + (renderWithContext defaultSDocContext (ep_prettyPass cfg)) + (ep_passDetails cfg) binds rules ; for_ (ep_lintPassResult cfg) $ \lp_cfg -> - lintPassResult' logger lp_cfg pass binds + lintPassResult logger lp_cfg binds } where - mb_flag = case coreDumpFlag pass of + mb_flag = case ep_dumpFlag cfg of Just flag | logHasDumpFlag logger flag -> Just flag | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag _ -> Nothing @@ -338,33 +340,6 @@ dumpPassResult logger dump_core_sizes unqual mb_flag hdr extra_info binds rules , text "------ Local rules for imported ids --------" , pprRules rules ] -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 - {- ************************************************************************ * * @@ -374,28 +349,30 @@ coreDumpFlag (CoreDoPasses {}) = Nothing -} data LintPassResultConfig = LintPassResultConfig - { lpr_diagOpts :: !DiagOpts - , lpr_platform :: !Platform - , lpr_makeLintFlags :: !(CoreToDo -> LintFlags) - , lpr_localsInScope :: ![Var] + { lpr_diagOpts :: !DiagOpts + , lpr_platform :: !Platform + , lpr_makeLintFlags :: !LintFlags + , lpr_showLintWarnings :: !Bool + , lpr_passPpr :: !SDoc + , lpr_localsInScope :: ![Var] } -lintPassResult' :: Logger -> LintPassResultConfig - -> CoreToDo -> CoreProgram -> IO () -lintPassResult' logger cfg pass binds +lintPassResult :: Logger -> LintPassResultConfig + -> CoreProgram -> IO () +lintPassResult logger cfg binds = do { let warns_and_errs = lintCoreBindings' (LintConfig { l_diagOpts = lpr_diagOpts cfg , l_platform = lpr_platform cfg - , l_flags = lpr_makeLintFlags cfg pass + , l_flags = lpr_makeLintFlags cfg , l_vars = lpr_localsInScope cfg }) binds ; Err.showPass logger $ "Core Linted result of " ++ - renderWithContext defaultSDocContext (ppr pass) + renderWithContext defaultSDocContext (lpr_passPpr cfg) ; displayLintResults logger - (showLintWarnings pass) (ppr pass) + (lpr_showLintWarnings cfg) (lpr_passPpr cfg) (pprCoreBindings binds) warns_and_errs } @@ -432,40 +409,6 @@ lint_banner string pass = text "*** Core Lint" <+> text string <+> text ": in result of" <+> pass <+> text "***" -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 (cds_mode cfg) of - InitialPhase -> False - _ -> True -showLintWarnings _ = True - -interactiveInScope :: InteractiveContext -> [Var] --- In GHCi we may lint expressions, or bindings arising from 'deriving' --- clauses, that mention variables bound in the interactive context. --- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context). --- So we have to tell Lint about them, lest it reports them as out of scope. --- --- We do this by find local-named things that may appear free in interactive --- context. This function is pretty revolting and quite possibly not quite right. --- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty --- so this is a (cheap) no-op. --- --- See #8215 for an example -interactiveInScope ictxt - = tyvars ++ ids - where - -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr - (cls_insts, _fam_insts) = ic_instances ictxt - te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) - te = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts cls_insts) - ids = typeEnvIds te - tyvars = tyCoVarsOfTypesList $ map idType ids - -- Why the type variables? How can the top level envt have free tyvars? - -- I think it's because of the GHCi debugger, which can bind variables - -- f :: [t] -> [t] - -- where t is a RuntimeUnk (see TcType) - -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs -- Returns (warnings, errors) diff --git a/compiler/GHC/Core/Lint/Interactive.hs b/compiler/GHC/Core/Lint/Interactive.hs new file mode 100644 index 0000000000..17c1c86bdc --- /dev/null +++ b/compiler/GHC/Core/Lint/Interactive.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +A ``lint'' pass to check for Core correctness. +See Note [Core Lint guarantee]. +-} + +module GHC.Core.Lint.Interactive ( + interactiveInScope, + ) where + +import GHC.Prelude + +import GHC.Runtime.Context + +import GHC.Core.Coercion +import GHC.Core.TyCo.FVs +import GHC.Core.InstEnv ( instanceDFunId, instEnvElts ) + +import GHC.Types.Id +import GHC.Types.TypeEnv + + +interactiveInScope :: InteractiveContext -> [Var] +-- In GHCi we may lint expressions, or bindings arising from 'deriving' +-- clauses, that mention variables bound in the interactive context. +-- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context). +-- So we have to tell Lint about them, lest it reports them as out of scope. +-- +-- We do this by find local-named things that may appear free in interactive +-- context. This function is pretty revolting and quite possibly not quite right. +-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty +-- so this is a (cheap) no-op. +-- +-- See #8215 for an example +interactiveInScope ictxt + = tyvars ++ ids + where + -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr + (cls_insts, _fam_insts) = ic_instances ictxt + te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) + te = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts cls_insts) + ids = typeEnvIds te + tyvars = tyCoVarsOfTypesList $ map idType ids + -- Why the type variables? How can the top level envt have free tyvars? + -- I think it's because of the GHCi debugger, which can bind variables + -- f :: [t] -> [t] + -- where t is a RuntimeUnk (see TcType) diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 7b44a6534e..28c0a5a262 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -9,21 +9,8 @@ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Opt.Monad ( - -- * Configuration of the core-to-core passes - CoreToDo(..), runWhen, runMaybe, - CoreDoSimplifyOpts(..), SimplMode(..), + -- * Types used in core-to-core passes FloatOutSwitches(..), - FloatEnable(..), - floatEnable, - pprPassDetails, - - -- * Plugins - CorePluginPass, bindsOnlyPass, - - -- * Counting - SimplCount, doSimplTick, doFreeSimplTick, simplCountN, - pprSimplCount, plusSimplCount, zeroSimplCount, - isZeroSimplCount, hasDetailedCounts, Tick(..), -- * The monad CoreM, runCoreM, @@ -59,11 +46,9 @@ import GHC.Driver.Session import GHC.Driver.Env import GHC.Core -import GHC.Core.Unfold +import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount ) -import GHC.Types.Basic ( CompilerPhase(..) ) import GHC.Types.Annotations -import GHC.Types.Var import GHC.Types.Unique.Supply import GHC.Types.Name.Env import GHC.Types.SrcLoc @@ -74,7 +59,6 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Logger import GHC.Utils.Monad -import GHC.Data.FastString import GHC.Data.IOEnv hiding ( liftIO, failM, failWithM ) import qualified GHC.Data.IOEnv as IOEnv @@ -85,181 +69,10 @@ import GHC.Unit.Module.ModGuts import GHC.Unit.External import Data.Bifunctor ( bimap ) -import Data.List (intersperse, groupBy, sortBy) -import Data.Ord import Data.Dynamic -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Map.Strict as MapStrict import Data.Word import Control.Monad import Control.Applicative ( Alternative(..) ) -import GHC.Utils.Panic (throwGhcException, GhcException(..), panic) - -{- -************************************************************************ -* * - The CoreToDo type and related types - Abstraction of core-to-core passes to run. -* * -************************************************************************ --} - -data CoreDoSimplifyOpts = CoreDoSimplifyOpts - { cds_max_iterations :: Int -- ^ Max iterations - , cds_mode :: SimplMode - } - -data CoreToDo -- These are diff core-to-core passes, - -- which may be invoked in any order, - -- as many times as you like. - - = CoreDoSimplify !CoreDoSimplifyOpts - -- ^ The core-to-core simplifier. - | CoreDoPluginPass String CorePluginPass - | CoreDoFloatInwards - | CoreDoFloatOutwards FloatOutSwitches - | CoreLiberateCase - | CoreDoPrintCore - | CoreDoStaticArgs - | CoreDoCallArity - | CoreDoExitify - | CoreDoDemand - | CoreDoCpr - | CoreDoWorkerWrapper - | CoreDoSpecialising - | CoreDoSpecConstr - | CoreCSE - | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules - -- matching this string - | CoreDoNothing -- Useful when building up - | CoreDoPasses [CoreToDo] -- lists of these things - - | CoreDesugar -- Right after desugaring, no simple optimisation yet! - | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces - -- Core output, and hence useful to pass to endPass - - | CoreTidy - | CorePrep - | CoreAddCallerCcs - | CoreAddLateCcs - -instance Outputable CoreToDo where - ppr (CoreDoSimplify _) = text "Simplifier" - ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s - ppr CoreDoFloatInwards = text "Float inwards" - ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) - ppr CoreLiberateCase = text "Liberate case" - ppr CoreDoStaticArgs = text "Static argument" - ppr CoreDoCallArity = text "Called arity analysis" - ppr CoreDoExitify = text "Exitification transformation" - ppr CoreDoDemand = text "Demand analysis" - ppr CoreDoCpr = text "Constructed Product Result analysis" - ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" - ppr CoreDoSpecialising = text "Specialise" - ppr CoreDoSpecConstr = text "SpecConstr" - ppr CoreCSE = text "Common sub-expression" - ppr CoreDesugar = text "Desugar (before optimization)" - ppr CoreDesugarOpt = text "Desugar (after optimization)" - ppr CoreTidy = text "Tidy Core" - ppr CoreAddCallerCcs = text "Add caller cost-centres" - ppr CoreAddLateCcs = text "Add late core cost-centres" - ppr CorePrep = text "CorePrep" - ppr CoreDoPrintCore = text "Print core" - ppr (CoreDoRuleCheck {}) = text "Rule check" - ppr CoreDoNothing = text "CoreDoNothing" - ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes - -pprPassDetails :: CoreToDo -> SDoc -pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n - , ppr md ] - where - n = cds_max_iterations cfg - md = cds_mode cfg - -pprPassDetails _ = Outputable.empty - - -data FloatEnable -- Controls local let-floating - = FloatDisabled -- Do no local let-floating - | FloatNestedOnly -- Local let-floating for nested (NotTopLevel) bindings only - | FloatEnabled -- Do local let-floating on all bindings - -floatEnable :: DynFlags -> FloatEnable -floatEnable dflags = - case (gopt Opt_LocalFloatOut dflags, gopt Opt_LocalFloatOutTopLevel dflags) of - (True, True) -> FloatEnabled - (True, False)-> FloatNestedOnly - (False, _) -> FloatDisabled - -{- -Note [Local floating] -~~~~~~~~~~~~~~~~~~~~~ -The Simplifier can perform local let-floating: it floats let-bindings -out of the RHS of let-bindings. See - Let-floating: moving bindings to give faster programs (ICFP'96) - https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/ - -Here's an example - x = let y = v+1 in (y,true) - -The RHS of x is a thunk. Much better to float that y-binding out to give - y = v+1 - x = (y,true) - -Not only have we avoided building a thunk, but any (case x of (p,q) -> ...) in -the scope of the x-binding can now be simplified. - -This local let-floating is done in GHC.Core.Opt.Simplify.prepareBinding, -controlled by the predicate GHC.Core.Opt.Simplify.Env.doFloatFromRhs. - -The `FloatEnable` data type controls where local let-floating takes place; -it allows you to specify that it should be done only for nested bindings; -or for top-level bindings as well; or not at all. - -Note that all of this is quite separate from the global FloatOut pass; -see GHC.Core.Opt.FloatOut. - --} - -data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad - = SimplMode - { sm_names :: [String] -- ^ Name(s) of the phase - , sm_phase :: CompilerPhase - , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options - , sm_rules :: !Bool -- ^ Whether RULES are enabled - , sm_inline :: !Bool -- ^ Whether inlining is enabled - , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled - , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled - , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? - , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled - , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out - , sm_logger :: !Logger - , sm_dflags :: DynFlags - -- Just for convenient non-monadic access; we don't override these. - -- - -- Used for: - -- - target platform (for `exprIsDupable` and `mkDupableAlt`) - -- - Opt_DictsCheap and Opt_PedanticBottoms general flags - -- - rules options (initRuleOpts) - -- - inlineCheck - } - -instance Outputable SimplMode where - ppr (SimplMode { sm_phase = p, sm_names = ss - , sm_rules = r, sm_inline = i - , sm_cast_swizzle = cs - , sm_eta_expand = eta, sm_case_case = cc }) - = text "SimplMode" <+> braces ( - sep [ text "Phase =" <+> ppr p <+> - brackets (text (concat $ intersperse "," ss)) <> comma - , pp_flag i (text "inline") <> comma - , pp_flag r (text "rules") <> comma - , pp_flag eta (text "eta-expand") <> comma - , pp_flag cs (text "cast-swizzle") <> comma - , pp_flag cc (text "case-of-case") ]) - where - pp_flag f s = ppUnless f (text "no") <+> s data FloatOutSwitches = FloatOutSwitches { floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if @@ -290,338 +103,6 @@ pprFloatOutSwitches sw , text "Consts =" <+> ppr (floatOutConstants sw) , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) --- The core-to-core pass ordering is derived from the DynFlags: -runWhen :: Bool -> CoreToDo -> CoreToDo -runWhen True do_this = do_this -runWhen False _ = CoreDoNothing - -runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo -runMaybe (Just x) f = f x -runMaybe Nothing _ = CoreDoNothing - -{- - -************************************************************************ -* * - Types for Plugins -* * -************************************************************************ --} - --- | A description of the plugin pass itself -type CorePluginPass = ModGuts -> CoreM ModGuts - -bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts -bindsOnlyPass pass guts - = do { binds' <- pass (mg_binds guts) - ; return (guts { mg_binds = binds' }) } - -{- -************************************************************************ -* * - Counting and logging -* * -************************************************************************ --} - -getVerboseSimplStats :: (Bool -> SDoc) -> SDoc -getVerboseSimplStats = getPprDebug -- For now, anyway - -zeroSimplCount :: DynFlags -> SimplCount -isZeroSimplCount :: SimplCount -> Bool -hasDetailedCounts :: SimplCount -> Bool -pprSimplCount :: SimplCount -> SDoc -doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount -doFreeSimplTick :: Tick -> SimplCount -> SimplCount -plusSimplCount :: SimplCount -> SimplCount -> SimplCount - -data SimplCount - = VerySimplCount !Int -- Used when don't want detailed stats - - | SimplCount { - ticks :: !Int, -- Total ticks - details :: !TickCounts, -- How many of each type - - n_log :: !Int, -- N - log1 :: [Tick], -- Last N events; <= opt_HistorySize, - -- most recent first - log2 :: [Tick] -- Last opt_HistorySize events before that - -- Having log1, log2 lets us accumulate the - -- recent history reasonably efficiently - } - -type TickCounts = Map Tick Int - -simplCountN :: SimplCount -> Int -simplCountN (VerySimplCount n) = n -simplCountN (SimplCount { ticks = n }) = n - -zeroSimplCount dflags - -- This is where we decide whether to do - -- the VerySimpl version or the full-stats version - | dopt Opt_D_dump_simpl_stats dflags - = SimplCount {ticks = 0, details = Map.empty, - n_log = 0, log1 = [], log2 = []} - | otherwise - = VerySimplCount 0 - -isZeroSimplCount (VerySimplCount n) = n==0 -isZeroSimplCount (SimplCount { ticks = n }) = n==0 - -hasDetailedCounts (VerySimplCount {}) = False -hasDetailedCounts (SimplCount {}) = True - -doFreeSimplTick tick sc@SimplCount { details = dts } - = sc { details = dts `addTick` tick } -doFreeSimplTick _ sc = sc - -doSimplTick dflags tick - sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) - | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } - | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } - where - sc1 = sc { ticks = tks+1, details = dts `addTick` tick } - -doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) - - -addTick :: TickCounts -> Tick -> TickCounts -addTick fm tick = MapStrict.insertWith (+) tick 1 fm - -plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) - sc2@(SimplCount { ticks = tks2, details = dts2 }) - = log_base { ticks = tks1 + tks2 - , details = MapStrict.unionWith (+) dts1 dts2 } - where - -- A hackish way of getting recent log info - log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 - | null (log2 sc2) = sc2 { log2 = log1 sc1 } - | otherwise = sc2 - -plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) -plusSimplCount lhs rhs = - throwGhcException . PprProgramError "plusSimplCount" $ vcat - [ text "lhs" - , pprSimplCount lhs - , text "rhs" - , pprSimplCount rhs - ] - -- We use one or the other consistently - -pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n -pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) - = vcat [text "Total ticks: " <+> int tks, - blankLine, - pprTickCounts dts, - getVerboseSimplStats $ \dbg -> if dbg - then - vcat [blankLine, - text "Log (most recent first)", - nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] - else Outputable.empty - ] - -{- Note [Which transformations are innocuous] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At one point (Jun 18) I wondered if some transformations (ticks) -might be "innocuous", in the sense that they do not unlock a later -transformation that does not occur in the same pass. If so, we could -refrain from bumping the overall tick-count for such innocuous -transformations, and perhaps terminate the simplifier one pass -earlier. - -But alas I found that virtually nothing was innocuous! This Note -just records what I learned, in case anyone wants to try again. - -These transformations are not innocuous: - -*** NB: I think these ones could be made innocuous - EtaExpansion - LetFloatFromLet - -LetFloatFromLet - x = K (let z = e2 in Just z) - prepareRhs transforms to - x2 = let z=e2 in Just z - x = K xs - And now more let-floating can happen in the - next pass, on x2 - -PreInlineUnconditionally - Example in spectral/cichelli/Auxil - hinsert = ...let lo = e in - let j = ...lo... in - case x of - False -> () - True -> case lo of I# lo' -> - ...j... - When we PreInlineUnconditionally j, lo's occ-info changes to once, - so it can be PreInlineUnconditionally in the next pass, and a - cascade of further things can happen. - -PostInlineUnconditionally - let x = e in - let y = ...x.. in - case .. of { A -> ...x...y... - B -> ...x...y... } - Current postinlineUnconditinaly will inline y, and then x; sigh. - - But PostInlineUnconditionally might also unlock subsequent - transformations for the same reason as PreInlineUnconditionally, - so it's probably not innocuous anyway. - -KnownBranch, BetaReduction: - May drop chunks of code, and thereby enable PreInlineUnconditionally - for some let-binding which now occurs once - -EtaExpansion: - Example in imaginary/digits-of-e1 - fail = \void. e where e :: IO () - --> etaExpandRhs - fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) - --> Next iteration of simplify - fail1 = \void. \s. (e |> g) s - fail = fail1 |> Void# -> sym g - And now inline 'fail' - -CaseMerge: - case x of y { - DEFAULT -> case y of z { pi -> ei } - alts2 } - ---> CaseMerge - case x of { pi -> let z = y in ei - ; alts2 } - The "let z=y" case-binder-swap gets dealt with in the next pass --} - -pprTickCounts :: Map Tick Int -> SDoc -pprTickCounts counts - = vcat (map pprTickGroup groups) - where - groups :: [[(Tick,Int)]] -- Each group shares a common tag - -- toList returns common tags adjacent - groups = groupBy same_tag (Map.toList counts) - same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 - -pprTickGroup :: [(Tick, Int)] -> SDoc -pprTickGroup group@((tick1,_):_) - = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) - 2 (vcat [ int n <+> pprTickCts tick - -- flip as we want largest first - | (tick,n) <- sortBy (flip (comparing snd)) group]) -pprTickGroup [] = panic "pprTickGroup" - -data Tick -- See Note [Which transformations are innocuous] - = PreInlineUnconditionally Id - | PostInlineUnconditionally Id - - | UnfoldingDone Id - | RuleFired FastString -- Rule name - - | LetFloatFromLet - | EtaExpansion Id -- LHS binder - | EtaReduction Id -- Binder on outer lambda - | BetaReduction Id -- Lambda binder - - - | CaseOfCase Id -- Bndr on *inner* case - | KnownBranch Id -- Case binder - | CaseMerge Id -- Binder on outer case - | AltMerge Id -- Case binder - | CaseElim Id -- Case binder - | CaseIdentity Id -- Case binder - | FillInCaseDefault Id -- Case binder - - | SimplifierDone -- Ticked at each iteration of the simplifier - -instance Outputable Tick where - ppr tick = text (tickString tick) <+> pprTickCts tick - -instance Eq Tick where - a == b = case a `cmpTick` b of - EQ -> True - _ -> False - -instance Ord Tick where - compare = cmpTick - -tickToTag :: Tick -> Int -tickToTag (PreInlineUnconditionally _) = 0 -tickToTag (PostInlineUnconditionally _) = 1 -tickToTag (UnfoldingDone _) = 2 -tickToTag (RuleFired _) = 3 -tickToTag LetFloatFromLet = 4 -tickToTag (EtaExpansion _) = 5 -tickToTag (EtaReduction _) = 6 -tickToTag (BetaReduction _) = 7 -tickToTag (CaseOfCase _) = 8 -tickToTag (KnownBranch _) = 9 -tickToTag (CaseMerge _) = 10 -tickToTag (CaseElim _) = 11 -tickToTag (CaseIdentity _) = 12 -tickToTag (FillInCaseDefault _) = 13 -tickToTag SimplifierDone = 16 -tickToTag (AltMerge _) = 17 - -tickString :: Tick -> String -tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" -tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" -tickString (UnfoldingDone _) = "UnfoldingDone" -tickString (RuleFired _) = "RuleFired" -tickString LetFloatFromLet = "LetFloatFromLet" -tickString (EtaExpansion _) = "EtaExpansion" -tickString (EtaReduction _) = "EtaReduction" -tickString (BetaReduction _) = "BetaReduction" -tickString (CaseOfCase _) = "CaseOfCase" -tickString (KnownBranch _) = "KnownBranch" -tickString (CaseMerge _) = "CaseMerge" -tickString (AltMerge _) = "AltMerge" -tickString (CaseElim _) = "CaseElim" -tickString (CaseIdentity _) = "CaseIdentity" -tickString (FillInCaseDefault _) = "FillInCaseDefault" -tickString SimplifierDone = "SimplifierDone" - -pprTickCts :: Tick -> SDoc -pprTickCts (PreInlineUnconditionally v) = ppr v -pprTickCts (PostInlineUnconditionally v)= ppr v -pprTickCts (UnfoldingDone v) = ppr v -pprTickCts (RuleFired v) = ppr v -pprTickCts LetFloatFromLet = Outputable.empty -pprTickCts (EtaExpansion v) = ppr v -pprTickCts (EtaReduction v) = ppr v -pprTickCts (BetaReduction v) = ppr v -pprTickCts (CaseOfCase v) = ppr v -pprTickCts (KnownBranch v) = ppr v -pprTickCts (CaseMerge v) = ppr v -pprTickCts (AltMerge v) = ppr v -pprTickCts (CaseElim v) = ppr v -pprTickCts (CaseIdentity v) = ppr v -pprTickCts (FillInCaseDefault v) = ppr v -pprTickCts _ = Outputable.empty - -cmpTick :: Tick -> Tick -> Ordering -cmpTick a b = case (tickToTag a `compare` tickToTag b) of - GT -> GT - EQ -> cmpEqTick a b - LT -> LT - -cmpEqTick :: Tick -> Tick -> Ordering -cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b -cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b -cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b -cmpEqTick (RuleFired a) (RuleFired b) = a `uniqCompareFS` b -cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b -cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b -cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b -cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b -cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b -cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b -cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b -cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b -cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b -cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b -cmpEqTick _ _ = EQ - {- ************************************************************************ * * @@ -648,9 +129,10 @@ newtype CoreWriter = CoreWriter { cw_simpl_count :: SimplCount } -emptyWriter :: DynFlags -> CoreWriter -emptyWriter dflags = CoreWriter { - cw_simpl_count = zeroSimplCount dflags +emptyWriter :: Bool -- ^ -ddump-simpl-stats + -> CoreWriter +emptyWriter dump_simpl_stats = CoreWriter { + cw_simpl_count = zeroSimplCount dump_simpl_stats } plusWriter :: CoreWriter -> CoreWriter -> CoreWriter @@ -729,8 +211,8 @@ runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m nop :: a -> CoreIOEnv (a, CoreWriter) nop x = do - r <- getEnv - return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r) + logger <- hsc_logger . cr_hsc_env <$> getEnv + return (x, emptyWriter $ logHasDumpFlag logger Opt_D_dump_simpl_stats) read :: (CoreReader -> a) -> CoreM a read f = CoreM $ getEnv >>= (\r -> nop (f r)) diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index b8ac982021..d1ca6a2165 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -13,27 +13,24 @@ 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.Lint ( endPass ) import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts ) +import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode, initGentleSimplMode ) import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts ) import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Platform.Ways ( hasWay, Way(WayProf) ) import GHC.Core import GHC.Core.Opt.CSE ( cseProgram ) -import GHC.Core.Rules ( mkRuleBase, - extendRuleBaseList, ruleCheckProgram, addRuleInfo, - getRules ) -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 ( 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 +import GHC.Core.Rules ( mkRuleBase, ruleCheckProgram, getRules ) +import GHC.Core.Ppr ( pprCoreBindings ) +import GHC.Core.Utils ( dumpIdInfoOfProgram ) +import GHC.Core.Lint ( lintAnnots ) +import GHC.Core.Lint.Interactive ( interactiveInScope ) +import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm ) import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Monad +import GHC.Core.Opt.Pipeline.Types import GHC.Core.Opt.FloatIn ( floatInwards ) import GHC.Core.Opt.FloatOut ( floatOutwards ) import GHC.Core.Opt.LiberateCase ( liberateCase ) @@ -54,29 +51,21 @@ import GHC.Utils.Error ( withTiming ) import GHC.Utils.Logger as Logger import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Trace -import GHC.Unit.External import GHC.Unit.Module.Env import GHC.Unit.Module.ModGuts import GHC.Unit.Module.Deps -import GHC.Runtime.Context - -import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Basic import GHC.Types.Demand ( zapDmdEnvSig ) -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Tickish -import GHC.Types.Unique.FM import GHC.Types.Name.Ppr +import GHC.Types.Var ( Var ) import Control.Monad import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Module + {- ************************************************************************ * * @@ -90,7 +79,7 @@ core2core hsc_env guts@(ModGuts { mg_module = mod , mg_loc = loc , mg_deps = deps , mg_rdr_env = rdr_env }) - = do { let builtin_passes = getCoreToDo logger dflags + = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars orph_mods = mkModuleSet (mod : dep_orphs deps) uniq_mask = 's' ; @@ -109,8 +98,9 @@ core2core hsc_env guts@(ModGuts { mg_module = mod ; return guts2 } where - logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + extra_vars = interactiveInScope (hsc_IC hsc_env) home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod , gwib_isBoot = NotBoot }) hpt_rule_base = mkRuleBase home_pkg_rules @@ -129,14 +119,13 @@ core2core hsc_env guts@(ModGuts { mg_module = mod ************************************************************************ -} -getCoreToDo :: Logger -> DynFlags -> [CoreToDo] -getCoreToDo logger dflags +getCoreToDo :: DynFlags -> RuleBase -> [Var] -> [CoreToDo] +getCoreToDo dflags rule_base extra_vars = flatten_todos core_todo where phases = simplPhases dflags max_iter = maxSimplIterations dflags rule_check = ruleCheck dflags - float_enable = floatEnable dflags const_fold = gopt Opt_CoreConstantFolding dflags call_arity = gopt Opt_CallArity dflags exitification = gopt Opt_Exitification dflags @@ -151,8 +140,6 @@ getCoreToDo logger dflags late_specialise = gopt Opt_LateSpecialise dflags static_args = gopt Opt_StaticArgumentTransformation dflags rules_on = gopt Opt_EnableRewriteRules dflags - eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags - pre_inline_on = gopt Opt_SimplPreInlining dflags ww_on = gopt Opt_WorkerWrapper dflags static_ptrs = xopt LangExt.StaticPointers dflags profiling = ways dflags `hasWay` WayProf @@ -167,27 +154,11 @@ getCoreToDo logger dflags maybe_strictness_before _ = CoreDoNothing - base_mode = SimplMode { sm_phase = panic "base_mode" - , sm_names = [] - , sm_dflags = dflags - , sm_logger = logger - , sm_uf_opts = unfoldingOpts dflags - , sm_rules = rules_on - , sm_eta_expand = eta_expand_on - , sm_cast_swizzle = True - , sm_inline = True - , sm_case_case = True - , sm_pre_inline = pre_inline_on - , sm_float_enable = float_enable - } - simpl_phase phase name iter = CoreDoPasses $ [ maybe_strictness_before phase - , CoreDoSimplify $ CoreDoSimplifyOpts iter - (base_mode { sm_phase = phase - , sm_names = [name] }) - + , CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter + (initSimplMode dflags phase name) rule_base , maybe_rule_check phase ] -- Run GHC's internal simplification phase, after all rules have run. @@ -195,15 +166,10 @@ getCoreToDo logger dflags simplify name = simpl_phase FinalPhase name max_iter -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently = CoreDoSimplify $ CoreDoSimplifyOpts max_iter - (base_mode { sm_phase = InitialPhase - , sm_names = ["Gentle"] - , sm_rules = rules_on -- Note [RULEs enabled in InitialPhase] - , sm_inline = True - -- See Note [Inline in InitialPhase] - , sm_case_case = False }) - -- Don't do case-of-case transformations. - -- This makes full laziness work better + -- See Note [Inline in InitialPhase] + -- See Note [RULEs enabled in InitialPhase] + simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter + (initGentleSimplMode dflags) rule_base dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper] else [CoreDoDemand,CoreDoCpr] @@ -389,6 +355,15 @@ getCoreToDo logger dflags flatten_todos passes ++ flatten_todos rest flatten_todos (todo : rest) = todo : flatten_todos rest +-- The core-to-core pass ordering is derived from the DynFlags: +runWhen :: Bool -> CoreToDo -> CoreToDo +runWhen True do_this = do_this +runWhen False _ = CoreDoNothing + +runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo +runMaybe (Just x) f = f x +runMaybe Nothing _ = CoreDoNothing + {- Note [Inline in InitialPhase] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is @@ -482,17 +457,19 @@ runCorePasses passes guts doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass guts = do logger <- getLogger + hsc_env <- getHscEnv dflags <- getDynFlags us <- getUniqueSupplyM p_fam_env <- getPackageFamInstEnv let platform = targetPlatform dflags let fam_envs = (p_fam_env, mg_fam_inst_env guts) + let prof_count_entries = gopt Opt_ProfCountEntries dflags let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' } case pass of - CoreDoSimplify cfg -> {-# SCC "Simplify" #-} - simplifyPgm cfg guts + CoreDoSimplify opts -> {-# SCC "Simplify" #-} + liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) opts guts CoreCSE -> {-# SCC "CommonSubExpr" #-} updateBinds cseProgram @@ -536,7 +513,7 @@ doCorePass pass guts = do addCallerCostCentres guts CoreAddLateCcs -> {-# SCC "AddLateCcs" #-} - addLateCostCentres guts + return (addLateCostCentres prof_count_entries guts) CoreDoPrintCore -> {-# SCC "PrintCore" #-} liftIO $ printCore logger (mg_binds guts) >> return guts @@ -581,500 +558,6 @@ ruleCheckPass current_phase pat guts = do rule_fn (mg_binds guts)) return guts -{- -************************************************************************ -* * - Gentle simplification -* * -************************************************************************ --} - -simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do - -> CoreExpr - -> IO CoreExpr --- simplifyExpr is called by the driver to simplify an --- expression typed in at the interactive prompt -simplifyExpr hsc_env expr - = withTiming logger (text "Simplify [expr]") (const ()) $ - do { eps <- hscEPS hsc_env ; - ; let fi_env = ( eps_fam_inst_env eps - , extendFamInstEnvList emptyFamInstEnv $ - snd $ ic_instances $ hsc_IC hsc_env ) - simpl_env = simplEnvForGHCi logger dflags - - ; let sz = exprSize expr - - ; (expr', counts) <- initSmpl logger dflags (eps_rule_base <$> hscEPS hsc_env) emptyRuleEnv fi_env sz $ - simplExprGently simpl_env expr - - ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats - "Simplifier statistics" FormatText (pprSimplCount counts) - - ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression" - FormatCore - (pprCoreExpr expr') - - ; return expr' - } - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - -simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr --- Simplifies an expression --- does occurrence analysis, then simplification --- and repeats (twice currently) because one pass --- alone leaves tons of crud. --- Used (a) for user expressions typed in at the interactive prompt --- (b) the LHS and RHS of a RULE --- (c) Template Haskell splices --- --- The name 'Gently' suggests that the SimplMode is InitialPhase, --- and in fact that is so.... but the 'Gently' in simplExprGently doesn't --- enforce that; it just simplifies the expression twice - --- It's important that simplExprGently does eta reduction; see --- Note [Simplify rule LHS] above. The --- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam) --- but only if -O is on. - -simplExprGently env expr = do - expr1 <- simplExpr env (occurAnalyseExpr expr) - simplExpr env (occurAnalyseExpr expr1) - -{- -************************************************************************ -* * -\subsection{The driver for the simplifier} -* * -************************************************************************ --} - -simplifyPgm :: CoreDoSimplifyOpts -> ModGuts -> CoreM ModGuts -simplifyPgm cfg guts - = do { hsc_env <- getHscEnv - ; rb <- getRuleBase - ; liftIOWithCount $ - simplifyPgmIO cfg hsc_env rb guts } - -simplifyPgmIO :: CoreDoSimplifyOpts - -> HscEnv - -> RuleBase - -> ModGuts - -> IO (SimplCount, ModGuts) -- New bindings - -simplifyPgmIO cfg@(CoreDoSimplifyOpts max_iterations mode) - hsc_env hpt_rule_base - guts@(ModGuts { mg_module = this_mod - , mg_rdr_env = rdr_env - , mg_deps = deps - , mg_binds = binds, mg_rules = rules - , mg_fam_inst_env = fam_inst_env }) - = do { (termination_msg, it_count, counts_out, guts') - <- do_iteration 1 [] binds rules - - ; when (logHasDumpFlag logger Opt_D_verbose_core2core - && logHasDumpFlag logger Opt_D_dump_simpl_stats) $ - logDumpMsg logger - "Simplifier statistics for following pass" - (vcat [text termination_msg <+> text "after" <+> ppr it_count - <+> text "iterations", - blankLine, - pprSimplCount counts_out]) - - ; return (counts_out, guts') - } - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env - simpl_env = mkSimplEnv mode - active_rule = activeRule mode - active_unf = activeUnfolding mode - - do_iteration :: Int --UniqSupply - -- -> Int -- Counts iterations - -> [SimplCount] -- Counts from earlier iterations, reversed - -> CoreProgram -- Bindings in - -> [CoreRule] -- and orphan rules - -> IO (String, Int, SimplCount, ModGuts) - - do_iteration iteration_no counts_so_far binds rules - -- iteration_no is the number of the iteration we are - -- about to begin, with '1' for the first - | iteration_no > max_iterations -- Stop if we've run out of iterations - = warnPprTrace (debugIsOn && (max_iterations > 2)) - "Simplifier bailing out" - ( hang (ppr this_mod <> text ", after" - <+> int max_iterations <+> text "iterations" - <+> (brackets $ hsep $ punctuate comma $ - map (int . simplCountN) (reverse counts_so_far))) - 2 (text "Size =" <+> ppr (coreBindsStats binds))) $ - - -- Subtract 1 from iteration_no to get the - -- number of iterations we actually completed - return ( "Simplifier baled out", iteration_no - 1 - , totalise counts_so_far - , guts { mg_binds = binds, mg_rules = rules } ) - - -- Try and force thunks off the binds; significantly reduces - -- space usage, especially with -O. JRS, 000620. - | let sz = coreBindsSize binds - , () <- sz `seq` () -- Force it - = do { - -- Occurrence analysis - let { tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm this_mod active_unf active_rule rules - binds - } ; - Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" - FormatCore - (pprCoreBindings tagged_binds); - - -- read_eps_rules: - -- We need to read rules from the EPS regularly because simplification can - -- poke on IdInfo thunks, which in turn brings in new rules - -- behind the scenes. Otherwise there's a danger we'll simply - -- miss the rules for Ids hidden inside imported inlinings - -- Hence just before attempting to match rules we read on the EPS - -- value and then combine it when the existing rule base. - -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`. - eps <- hscEPS hsc_env ; - let { read_eps_rules = eps_rule_base <$> hscEPS hsc_env - ; rule_base = extendRuleBaseList hpt_rule_base rules - ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) - ; vis_orphs = this_mod : dep_orphs deps } ; - - -- Simplify the program - ((binds1, rules1), counts1) <- - initSmpl logger dflags read_eps_rules (mkRuleEnv rule_base vis_orphs) fam_envs sz $ - do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} - simplTopBinds simpl_env tagged_binds - - -- Apply the substitution to rules defined in this module - -- for imported Ids. Eg RULE map my_f = blah - -- If we have a substitution my_f :-> other_f, we'd better - -- apply it to the rule to, or it'll never match - ; rules1 <- simplImpRules env1 rules - - ; return (getTopFloatBinds floats, rules1) } ; - - -- Stop if nothing happened; don't dump output - -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Monad - if isZeroSimplCount counts1 then - return ( "Simplifier reached fixed point", iteration_no - , totalise (counts1 : counts_so_far) -- Include "free" ticks - , guts { mg_binds = binds1, mg_rules = rules1 } ) - else do { - -- Short out indirections - -- We do this *after* at least one run of the simplifier - -- because indirection-shorting uses the export flag on *occurrences* - -- and that isn't guaranteed to be ok until after the first run propagates - -- stuff from the binding site to its occurrences - -- - -- ToDo: alas, this means that indirection-shorting does not happen at all - -- if the simplifier does nothing (not common, I know, but unsavoury) - let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; - - -- Dump the result of this iteration - let { dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags) } ; - dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ; - lintPassResult hsc_env (CoreDoSimplify cfg) binds2 ; - - -- Loop - do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 - } } -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "do_iteration" -#endif - where - -- Remember the counts_so_far are reversed - totalise :: [SimplCount] -> SimplCount - totalise = foldr (\c acc -> acc `plusSimplCount` c) - (zeroSimplCount dflags) - -------------------- -dump_end_iteration :: Logger -> Bool -> PrintUnqualified -> Int - -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts binds rules - = dumpPassResult logger dump_core_sizes print_unqual mb_flag hdr pp_counts binds rules - where - mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations - | otherwise = Nothing - -- Show details if Opt_D_dump_simpl_iterations is on - - hdr = "Simplifier iteration=" ++ show iteration_no - pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr - , pprSimplCount counts - , text "---- End of simplifier counts for" <+> text hdr ] - -{- -************************************************************************ -* * - Shorting out indirections -* * -************************************************************************ - -If we have this: - - x_local = <expression> - ...bindings... - x_exported = x_local - -where x_exported is exported, and x_local is not, then we replace it with this: - - x_exported = <expression> - x_local = x_exported - ...bindings... - -Without this we never get rid of the x_exported = x_local thing. This -save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and -makes strictness information propagate better. This used to happen in -the final phase, but it's tidier to do it here. - -Note [Messing up the exported Id's RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must be careful about discarding (obviously) or even merging the -RULES on the exported Id. The example that went bad on me at one stage -was this one: - - iterate :: (a -> a) -> a -> [a] - [Exported] - iterate = iterateList - - iterateFB c f x = x `c` iterateFB c f (f x) - iterateList f x = x : iterateList f (f x) - [Not exported] - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterateList - #-} - -This got shorted out to: - - iterateList :: (a -> a) -> a -> [a] - iterateList = iterate - - iterateFB c f x = x `c` iterateFB c f (f x) - iterate f x = x : iterate f (f x) - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterate - #-} - -And now we get an infinite loop in the rule system - iterate f x -> build (\cn -> iterateFB c f x) - -> iterateFB (:) f x - -> iterate f x - -Old "solution": - use rule switching-off pragmas to get rid - of iterateList in the first place - -But in principle the user *might* want rules that only apply to the Id -they say. And inline pragmas are similar - {-# NOINLINE f #-} - f = local - local = <stuff> -Then we do not want to get rid of the NOINLINE. - -Hence hasShortableIdinfo. - - -Note [Rules and indirection-zapping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Problem: what if x_exported has a RULE that mentions something in ...bindings...? -Then the things mentioned can be out of scope! Solution - a) Make sure that in this pass the usage-info from x_exported is - available for ...bindings... - b) If there are any such RULES, rec-ify the entire top-level. - It'll get sorted out next time round - -Other remarks -~~~~~~~~~~~~~ -If more than one exported thing is equal to a local thing (i.e., the -local thing really is shared), then we do one only: -\begin{verbatim} - x_local = .... - x_exported1 = x_local - x_exported2 = x_local -==> - x_exported1 = .... - - x_exported2 = x_exported1 -\end{verbatim} - -We rely on prior eta reduction to simplify things like -\begin{verbatim} - x_exported = /\ tyvars -> x_local tyvars -==> - x_exported = x_local -\end{verbatim} -Hence,there's a possibility of leaving unchanged something like this: -\begin{verbatim} - x_local = .... - x_exported1 = x_local Int -\end{verbatim} -By the time we've thrown away the types in STG land this -could be eliminated. But I don't think it's very common -and it's dangerous to do this fiddling in STG land -because we might eliminate a binding that's mentioned in the -unfolding for something. - -Note [Indirection zapping and ticks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unfortunately this is another place where we need a special case for -ticks. The following happens quite regularly: - - x_local = <expression> - x_exported = tick<x> x_local - -Which we want to become: - - x_exported = tick<x> <expression> - -As it makes no sense to keep the tick and the expression on separate -bindings. Note however that this might increase the ticks scoping -over the execution of x_local, so we can only do this for floatable -ticks. More often than not, other references will be unfoldings of -x_exported, and therefore carry the tick anyway. --} - -type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks - -shortOutIndirections :: CoreProgram -> CoreProgram -shortOutIndirections binds - | isEmptyVarEnv ind_env = binds - | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping] - | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff - where - ind_env = makeIndEnv binds - -- These exported Ids are the subjects of the indirection-elimination - exp_ids = map fst $ nonDetEltsUFM ind_env - -- It's OK to use nonDetEltsUFM here because we forget the ordering - -- by immediately converting to a set or check if all the elements - -- satisfy a predicate. - exp_id_set = mkVarSet exp_ids - no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids - binds' = concatMap zap binds - - zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] - zap (Rec pairs) = [Rec (concatMap zapPair pairs)] - - zapPair (bndr, rhs) - | bndr `elemVarSet` exp_id_set - = [] -- Kill the exported-id binding - - | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr - , (exp_id', lcl_id') <- transferIdInfo exp_id bndr - = -- Turn a local-id binding into two bindings - -- exp_id = rhs; lcl_id = exp_id - [ (exp_id', mkTicks ticks rhs), - (lcl_id', Var exp_id') ] - - | otherwise - = [(bndr,rhs)] - -makeIndEnv :: [CoreBind] -> IndEnv -makeIndEnv binds - = foldl' add_bind emptyVarEnv binds - where - add_bind :: IndEnv -> CoreBind -> IndEnv - add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs) - add_bind env (Rec pairs) = foldl' add_pair env pairs - - add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv - add_pair env (exported_id, exported) - | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported - , shortMeOut env exported_id local_id - = extendVarEnv env local_id (exported_id, ticks) - add_pair env _ = env - ------------------ -shortMeOut :: IndEnv -> Id -> Id -> Bool -shortMeOut ind_env exported_id local_id --- The if-then-else stuff is just so I can get a pprTrace to see --- how often I don't get shorting out because of IdInfo stuff - = if isExportedId exported_id && -- Only if this is exported - - isLocalId local_id && -- Only if this one is defined in this - -- module, so that we *can* change its - -- binding to be the exported thing! - - not (isExportedId local_id) && -- Only if this one is not itself exported, - -- since the transformation will nuke it - - not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for - then - if hasShortableIdInfo exported_id - then True -- See Note [Messing up the exported Id's RULES] - else warnPprTrace True "Not shorting out" (ppr exported_id) False - else - False - ------------------ -hasShortableIdInfo :: Id -> Bool --- True if there is no user-attached IdInfo on exported_id, --- so we can safely discard it --- See Note [Messing up the exported Id's RULES] -hasShortableIdInfo id - = isEmptyRuleInfo (ruleInfo info) - && isDefaultInlinePragma (inlinePragInfo info) - && not (isStableUnfolding (realUnfoldingInfo info)) - where - info = idInfo id - ------------------ -{- Note [Transferring IdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - lcl_id = e; exp_id = lcl_id - -and lcl_id has useful IdInfo, we don't want to discard it by going - gbl_id = e; lcl_id = gbl_id - -Instead, transfer IdInfo from lcl_id to exp_id, specifically -* (Stable) unfolding -* Strictness -* Rules -* Inline pragma - -Overwriting, rather than merging, seems to work ok. - -For the lcl_id we - -* Zap the InlinePragma. It might originally have had a NOINLINE, which - we have now transferred; and we really want the lcl_id to inline now - that its RHS is trivial! - -* Zap any Stable unfolding. agian, we want lcl_id = gbl_id to inline, - replacing lcl_id by gbl_id. That won't happen if lcl_id has its original - great big Stable unfolding --} - -transferIdInfo :: Id -> Id -> (Id, Id) --- See Note [Transferring IdInfo] -transferIdInfo exported_id local_id - = ( modifyIdInfo transfer exported_id - , modifyIdInfo zap_info local_id ) - where - local_info = idInfo local_id - transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info - `setCprSigInfo` cprSigInfo local_info - `setUnfoldingInfo` realUnfoldingInfo local_info - `setInlinePragInfo` inlinePragInfo local_info - `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info - new_info = setRuleInfoHead (idName exported_id) - (ruleInfo local_info) - -- Remember to set the function-name field of the - -- rules as we transfer them from one function to another - - zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma - `setUnfoldingInfo` noUnfolding - - dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram dmdAnal logger dflags fam_envs rules binds = do let !opts = DmdAnalOpts diff --git a/compiler/GHC/Core/Opt/Pipeline/Types.hs b/compiler/GHC/Core/Opt/Pipeline/Types.hs new file mode 100644 index 0000000000..ff871b08ff --- /dev/null +++ b/compiler/GHC/Core/Opt/Pipeline/Types.hs @@ -0,0 +1,101 @@ +module GHC.Core.Opt.Pipeline.Types ( + -- * Configuration of the core-to-core passes + CorePluginPass, CoreToDo(..), + bindsOnlyPass, pprPassDetails, + ) where + +import GHC.Prelude + +import GHC.Core ( CoreProgram ) +import GHC.Core.Opt.Monad ( CoreM, FloatOutSwitches ) +import GHC.Core.Opt.Simplify ( SimplifyOpts(..) ) + +import GHC.Types.Basic ( CompilerPhase(..) ) +import GHC.Unit.Module.ModGuts +import GHC.Utils.Outputable as Outputable + +{- +************************************************************************ +* * + The CoreToDo type and related types + Abstraction of core-to-core passes to run. +* * +************************************************************************ +-} + +-- | A description of the plugin pass itself +type CorePluginPass = ModGuts -> CoreM ModGuts + +bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts +bindsOnlyPass pass guts + = do { binds' <- pass (mg_binds guts) + ; return (guts { mg_binds = binds' }) } + +data CoreToDo -- These are diff core-to-core passes, + -- which may be invoked in any order, + -- as many times as you like. + + = CoreDoSimplify !SimplifyOpts + -- ^ The core-to-core simplifier. + | CoreDoPluginPass String CorePluginPass + | CoreDoFloatInwards + | CoreDoFloatOutwards FloatOutSwitches + | CoreLiberateCase + | CoreDoPrintCore + | CoreDoStaticArgs + | CoreDoCallArity + | CoreDoExitify + | CoreDoDemand + | CoreDoCpr + | CoreDoWorkerWrapper + | CoreDoSpecialising + | CoreDoSpecConstr + | CoreCSE + | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules + -- matching this string + | CoreDoNothing -- Useful when building up + | CoreDoPasses [CoreToDo] -- lists of these things + + | CoreDesugar -- Right after desugaring, no simple optimisation yet! + | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces + -- Core output, and hence useful to pass to endPass + + | CoreTidy + | CorePrep + | CoreAddCallerCcs + | CoreAddLateCcs + +instance Outputable CoreToDo where + ppr (CoreDoSimplify _) = text "Simplifier" + ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s + ppr CoreDoFloatInwards = text "Float inwards" + ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) + ppr CoreLiberateCase = text "Liberate case" + ppr CoreDoStaticArgs = text "Static argument" + ppr CoreDoCallArity = text "Called arity analysis" + ppr CoreDoExitify = text "Exitification transformation" + ppr CoreDoDemand = text "Demand analysis" + ppr CoreDoCpr = text "Constructed Product Result analysis" + ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" + ppr CoreDoSpecialising = text "Specialise" + ppr CoreDoSpecConstr = text "SpecConstr" + ppr CoreCSE = text "Common sub-expression" + ppr CoreDesugar = text "Desugar (before optimization)" + ppr CoreDesugarOpt = text "Desugar (after optimization)" + ppr CoreTidy = text "Tidy Core" + ppr CoreAddCallerCcs = text "Add caller cost-centres" + ppr CoreAddLateCcs = text "Add late core cost-centres" + ppr CorePrep = text "CorePrep" + ppr CoreDoPrintCore = text "Print core" + ppr (CoreDoRuleCheck {}) = text "Rule check" + ppr CoreDoNothing = text "CoreDoNothing" + ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes + +pprPassDetails :: CoreToDo -> SDoc +pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n + , ppr md ] + where + n = so_iterations cfg + md = so_mode cfg + +pprPassDetails _ = Outputable.empty diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 0f842be2d3..33ecf3cb86 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -1,4324 +1,561 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[Simplify]{The main module of the simplifier} --} - +{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiWayIf #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} -module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplImpRules ) where +module GHC.Core.Opt.Simplify + ( SimplifyExprOpts(..), SimplifyOpts(..) + , simplifyExpr, simplifyPgm + ) where import GHC.Prelude -import GHC.Platform - -import GHC.Driver.Session +import GHC.Driver.Flags import GHC.Core -import GHC.Core.Opt.Simplify.Monad -import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) +import GHC.Core.Rules ( extendRuleBaseList, extendRuleEnv, addRuleInfo ) +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 ) +import GHC.Core.Lint ( LintPassResultConfig, dumpPassResult, lintPassResult ) +import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) +import GHC.Core.Opt.Simplify.Utils ( activeRule, activeUnfolding ) import GHC.Core.Opt.Simplify.Env -import GHC.Core.Opt.Simplify.Utils -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs ) -import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) -import qualified GHC.Core.Make -import GHC.Core.Coercion hiding ( substCo, substCoVar ) -import GHC.Core.Reduction -import GHC.Core.Coercion.Opt ( optCoercion ) -import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) -import GHC.Core.DataCon - ( DataCon, dataConWorkId, dataConRepStrictness - , dataConRepArgTys, isUnboxedTupleDataCon - , StrictnessMark (..) ) -import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) ) -import GHC.Core.Ppr ( pprCoreExpr ) -import GHC.Core.Unfold -import GHC.Core.Unfold.Make -import GHC.Core.Utils -import GHC.Core.Opt.Arity ( ArityType, exprArity, getBotArity - , pushCoTyArg, pushCoValArg - , typeArity, arityTypeArity, etaExpandAT ) -import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) -import GHC.Core.FVs ( mkRuleInfo ) -import GHC.Core.Rules ( lookupRule, getRules ) -import GHC.Core.Multiplicity +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Opt.Stats ( simplCountN ) +import GHC.Core.FamInstEnv + +import GHC.Utils.Error ( withTiming ) +import GHC.Utils.Logger as Logger +import GHC.Utils.Outputable +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Trace -import GHC.Driver.Config.Core.Rules ( initRuleOpts ) +import GHC.Unit.Env ( UnitEnv, ueEPS ) +import GHC.Unit.External +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.Deps -import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326 -import GHC.Types.SourceText import GHC.Types.Id -import GHC.Types.Id.Make ( seqId ) import GHC.Types.Id.Info -import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) -import GHC.Types.Demand -import GHC.Types.Cpr ( mkCprSig, botCpr ) -import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic +import GHC.Types.Var.Set +import GHC.Types.Var.Env import GHC.Types.Tickish -import GHC.Types.Var ( isTyCoVar ) -import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) -import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) -import GHC.Builtin.Names( runRWKey ) - -import GHC.Data.Maybe ( isNothing, orElse ) -import GHC.Data.FastString -import GHC.Unit.Module ( moduleName ) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Trace -import GHC.Utils.Monad ( mapAccumLM, liftIO ) -import GHC.Utils.Logger -import GHC.Utils.Misc +import GHC.Types.Unique.FM +import GHC.Types.Name.Ppr import Control.Monad +import Data.Foldable ( for_ ) -{- -The guts of the simplifier is in this module, but the driver loop for -the simplifier is in GHC.Core.Opt.Pipeline - -Note [The big picture] -~~~~~~~~~~~~~~~~~~~~~~ -The general shape of the simplifier is this: - - simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) - simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) - - * SimplEnv contains - - Simplifier mode (which includes DynFlags for convenience) - - Ambient substitution - - InScopeSet - - * SimplFloats contains - - Let-floats (which includes ok-for-spec case-floats) - - Join floats - - InScopeSet (including all the floats) - - * Expressions - simplExpr :: SimplEnv -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - The result of simplifying an /expression/ is (floats, expr) - - A bunch of floats (let bindings, join bindings) - - A simplified expression. - The overall result is effectively (let floats in expr) - - * Bindings - simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) - The result of simplifying a binding is - - A bunch of floats, the last of which is the simplified binding - There may be auxiliary bindings too; see prepareRhs - - An environment suitable for simplifying the scope of the binding - - The floats may also be empty, if the binding is inlined unconditionally; - in that case the returned SimplEnv will have an augmented substitution. - - The returned floats and env both have an in-scope set, and they are - guaranteed to be the same. - - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -The simplifier used to guarantee that the output had no shadowing, but -it does not do so any more. (Actually, it never did!) The reason is -documented with simplifyArgs. - - -Eta expansion -~~~~~~~~~~~~~~ -For eta expansion, we want to catch things like - - case e of (a,b) -> \x -> case a of (p,q) -> \y -> r - -If the \x was on the RHS of a let, we'd eta expand to bring the two -lambdas together. And in general that's a good thing to do. Perhaps -we should eta expand wherever we find a (value) lambda? Then the eta -expansion at a let RHS can concentrate solely on the PAP case. - -Note [In-scope set as a substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As per Note [Lookups in in-scope set], an in-scope set can act as -a substitution. Specifically, it acts as a substitution from variable to -variables /with the same unique/. - -Why do we need this? Well, during the course of the simplifier, we may want to -adjust inessential properties of a variable. For instance, when performing a -beta-reduction, we change - - (\x. e) u ==> let x = u in e - -We typically want to add an unfolding to `x` so that it inlines to (the -simplification of) `u`. - -We do that by adding the unfolding to the binder `x`, which is added to the -in-scope set. When simplifying occurrences of `x` (every occurrence!), they are -replaced by their “updated” version from the in-scope set, hence inherit the -unfolding. This happens in `SimplEnv.substId`. - -Another example. Consider - - case x of y { Node a b -> ...y... - ; Leaf v -> ...y... } - -In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we -want y's unfolding to be (Leaf v). We achieve this by adding the appropriate -unfolding to y, and re-adding it to the in-scope set. See the calls to -`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere. - -It's quite convenient. This way we don't need to manipulate the substitution all -the time: every update to a binder is automatically reflected to its bound -occurrences. - -Note [Bangs in the Simplifier] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Both SimplFloats and SimplEnv do *not* generally benefit from making -their fields strict. I don't know if this is because of good use of -laziness or unintended side effects like closures capturing more variables -after WW has run. - -But the end result is that we keep these lazy, but force them in some places -where we know it's beneficial to the compiler. - -Similarly environments returned from functions aren't *always* beneficial to -force. In some places they would never be demanded so forcing them early -increases allocation. In other places they almost always get demanded so -it's worthwhile to force them early. - -Would it be better to through every allocation of e.g. SimplEnv and decide -wether or not to make this one strict? Absolutely! Would be a good use of -someones time? Absolutely not! I made these strict that showed up during -a profiled build or which I noticed while looking at core for one reason -or another. - -The result sadly is that we end up with "random" bangs in the simplifier -where we sometimes force e.g. the returned environment from a function and -sometimes we don't for the same function. Depending on the context around -the call. The treatment is also not very consistent. I only added bangs -where I saw it making a difference either in the core or benchmarks. Some -patterns where it would be beneficial aren't convered as a consequence as -I neither have the time to go through all of the core and some cases are -too small to show up in benchmarks. - - - -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ --} - -simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) --- See Note [The big picture] -simplTopBinds env0 binds0 - = do { -- Put all the top-level binders into scope at the start - -- so that if a rewrite rule has unexpectedly brought - -- anything into scope, then we don't get a complaint about that. - -- It's rather as if the top-level binders were imported. - -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal". - -- See Note [Bangs in the Simplifier] - ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) - ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 - ; freeTick SimplifierDone - ; return (floats, env2) } - where - -- We need to track the zapped top-level binders, because - -- they should have their fragile IdInfo zapped (notably occurrence info) - -- That's why we run down binds and bndrs' simultaneously. - -- - simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) - simpl_binds env [] = return (emptyFloats env, env) - simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind - ; (floats, env2) <- simpl_binds env1 binds - -- See Note [Bangs in the Simplifier] - ; let !floats1 = float `addFloats` floats - ; return (floats1, env2) } - - simpl_bind env (Rec pairs) - = simplRecBind env (BC_Let TopLevel Recursive) pairs - simpl_bind env (NonRec b r) - = do { let bind_cxt = BC_Let TopLevel NonRecursive - ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt - ; simplRecOrTopPair env' bind_cxt b b' r } +#if __GLASGOW_HASKELL__ <= 810 +import GHC.Utils.Panic ( panic ) +#endif {- ************************************************************************ * * - Lazy bindings -* * -************************************************************************ - -simplRecBind is used for - * recursive bindings only --} - -simplRecBind :: SimplEnv -> BindContext - -> [(InId, InExpr)] - -> SimplM (SimplFloats, SimplEnv) -simplRecBind env0 bind_cxt pairs0 - = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0 - ; let new_bndrs = map sndOf3 triples - ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env -> - go env triples - ; return (mkRecFloats rec_floats, env2) } - where - add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) - -- Add the (substituted) rules to the binder - add_rules env (bndr, rhs) - = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt - ; return (env', (bndr, bndr', rhs)) } - - go env [] = return (emptyFloats env, env) - - go env ((old_bndr, new_bndr, rhs) : pairs) - = do { (float, env1) <- simplRecOrTopPair env bind_cxt - old_bndr new_bndr rhs - ; (floats, env2) <- go env1 pairs - ; return (float `addFloats` floats, env2) } - -{- -simplOrTopPair is used for - * recursive bindings (whether top level or not) - * top-level non-recursive bindings - -It assumes the binder has already been simplified, but not its IdInfo. --} - -simplRecOrTopPair :: SimplEnv - -> BindContext - -> InId -> OutBndr -> InExpr -- Binder and rhs - -> SimplM (SimplFloats, SimplEnv) - -simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs - | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) - old_bndr rhs env - = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} - simplTrace env "SimplBindr:inline-uncond" (ppr old_bndr) $ - do { tick (PreInlineUnconditionally old_bndr) - ; return ( emptyFloats env, env' ) } - - | otherwise - = case bind_cxt of - BC_Join cont -> simplTrace env "SimplBind:join" (ppr old_bndr) $ - simplJoinBind env cont old_bndr new_bndr rhs env - - BC_Let top_lvl is_rec -> simplTrace env "SimplBind:normal" (ppr old_bndr) $ - simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env - -simplTrace :: SimplEnv -> String -> SDoc -> a -> a -simplTrace env herald doc thing_inside - | not (logHasDumpFlag logger Opt_D_verbose_core2core) - = thing_inside - | otherwise - = logTraceMsg logger herald doc thing_inside - where - logger = seLogger env - --------------------------- -simplLazyBind :: SimplEnv - -> TopLevelFlag -> RecFlag - -> InId -> OutId -- Binder, both pre-and post simpl - -- Not a JoinId - -- The OutId has IdInfo, except arity, unfolding - -- Ids only, no TyVars - -> InExpr -> SimplEnv -- The RHS and its environment - -> SimplM (SimplFloats, SimplEnv) --- Precondition: the OutId is already in the InScopeSet of the incoming 'env' --- Precondition: not a JoinId --- Precondition: rhs obeys the let-can-float invariant --- NOT used for JoinIds -simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se - = assert (isId bndr ) - assertPpr (not (isJoinId bndr)) (ppr bndr) $ - -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ - do { let !rhs_env = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier] - (tvs, body) = case collectTyAndValBinders rhs of - (tvs, [], body) - | surely_not_lam body -> (tvs, body) - _ -> ([], rhs) - - surely_not_lam (Lam {}) = False - surely_not_lam (Tick t e) - | not (tickishFloatable t) = surely_not_lam e - -- eta-reduction could float - surely_not_lam _ = True - -- Do not do the "abstract tyvar" thing if there's - -- a lambda inside, because it defeats eta-reduction - -- f = /\a. \x. g a x - -- should eta-reduce. - - ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs - -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils - - -- Simplify the RHS - ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) - is_rec (idDemandInfo bndr) - ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont - - -- ANF-ise a constructor or PAP rhs - ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-} - prepareBinding env top_lvl is_rec - False -- Not strict; this is simplLazyBind - bndr1 body_floats0 body0 - -- Subtle point: we do not need or want tvs' in the InScope set - -- of body_floats2, so we pass in 'env' not 'body_env'. - -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do - -- more renaming than necessary => extra work (see !7777 and test T16577). - -- Don't need: we wrap tvs' around the RHS anyway. - - ; (rhs_floats, body3) - <- if isEmptyFloats body_floats2 || null tvs then -- Simple floating - {-#SCC "simplLazyBind-simple-floating" #-} - return (body_floats2, body2) - - else -- Non-empty floats, and non-empty tyvars: do type-abstraction first - {-#SCC "simplLazyBind-type-abstraction-first" #-} - do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl - tvs' body_floats2 body2 - ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds - ; return (poly_floats, body3) } - - ; let env' = env `setInScopeFromF` rhs_floats - ; rhs' <- rebuildLam env' tvs' body3 rhs_cont - ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs' - ; return (rhs_floats `addFloats` bind_float, env2) } - --------------------------- -simplJoinBind :: SimplEnv - -> SimplCont - -> InId -> OutId -- Binder, both pre-and post simpl - -- The OutId has IdInfo, except arity, - -- unfolding - -> InExpr -> SimplEnv -- The right hand side and its env - -> SimplM (SimplFloats, SimplEnv) -simplJoinBind env cont old_bndr new_bndr rhs rhs_se - = do { let rhs_env = rhs_se `setInScopeFromE` env - ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont - ; completeBind env (BC_Join cont) old_bndr new_bndr rhs' } - --------------------------- -simplNonRecX :: SimplEnv - -> InId -- Old binder; not a JoinId - -> OutExpr -- Simplified RHS - -> SimplM (SimplFloats, SimplEnv) --- A specialised variant of simplNonRec used when the RHS is already --- simplified, notably in knownCon. It uses case-binding where necessary. --- --- Precondition: rhs satisfies the let-can-float invariant - -simplNonRecX env bndr new_rhs - | assertPpr (not (isJoinId bndr)) (ppr bndr) $ - isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } - = return (emptyFloats env, env) -- Here c is dead, and we avoid - -- creating the binding c = (a,b) - - | Coercion co <- new_rhs - = return (emptyFloats env, extendCvSubst env bndr co) - - | exprIsTrivial new_rhs -- Short-cut for let x = y in ... - -- This case would ultimately land in postInlineUnconditionally - -- but it seems not uncommon, and avoids a lot of faff to do it here - = return (emptyFloats env - , extendIdSubst env bndr (DoneEx new_rhs Nothing)) - - | otherwise - = do { (env1, new_bndr) <- simplBinder env bndr - ; let is_strict = isStrictId new_bndr - -- isStrictId: use new_bndr because the InId bndr might not have - -- a fixed runtime representation, which isStrictId doesn't expect - -- c.f. Note [Dark corner with representation polymorphism] - - ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict - new_bndr (emptyFloats env) new_rhs - -- NB: it makes a surprisingly big difference (5% in compiler allocation - -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env', - -- because this is simplNonRecX, so bndr is not in scope in the RHS. - - ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats) - (BC_Let NotTopLevel NonRecursive) - bndr new_bndr rhs1 - -- Must pass env1 to completeBind in case simplBinder had to clone, - -- and extended the substitution with [bndr :-> new_bndr] - - ; return (rhs_floats `addFloats` bind_float, env2) } - - -{- ********************************************************************* -* * - Cast worker/wrapper -* * -************************************************************************ - -Note [Cast worker/wrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have a binding - x = e |> co -we want to do something very similar to worker/wrapper: - $wx = e - x = $wx |> co - -We call this making a cast worker/wrapper in tryCastWorkerWrapper. - -The main motivaiton is that x can be inlined freely. There's a chance -that e will be a constructor application or function, or something -like that, so moving the coercion to the usage site may well cancel -the coercions and lead to further optimisation. Example: - - data family T a :: * - data instance T Int = T Int - - foo :: Int -> Int -> Int - foo m n = ... - where - t = T m - go 0 = 0 - go n = case t of { T m -> go (n-m) } - -- This case should optimise - -A second reason for doing cast worker/wrapper is that the worker/wrapper -pass after strictness analysis can't deal with RHSs like - f = (\ a b c. blah) |> co -Instead, it relies on cast worker/wrapper to get rid of the cast, -leaving a simpler job for demand-analysis worker/wrapper. See #19874. - -Wrinkles - -1. We must /not/ do cast w/w on - f = g |> co - otherwise it'll just keep repeating forever! You might think this - is avoided because the call to tryCastWorkerWrapper is guarded by - preInlineUnconditinally, but I'm worried that a loop-breaker or an - exported Id might say False to preInlineUnonditionally. - -2. We need to be careful with inline/noinline pragmas: - rec { {-# NOINLINE f #-} - f = (...g...) |> co - ; g = ...f... } - This is legitimate -- it tells GHC to use f as the loop breaker - rather than g. Now we do the cast thing, to get something like - rec { $wf = ...g... - ; f = $wf |> co - ; g = ...f... } - Where should the NOINLINE pragma go? If we leave it on f we'll get - rec { $wf = ...g... - ; {-# NOINLINE f #-} - f = $wf |> co - ; g = ...f... } - and that is bad: the whole point is that we want to inline that - cast! We want to transfer the pagma to $wf: - rec { {-# NOINLINE $wf #-} - $wf = ...g... - ; f = $wf |> co - ; g = ...f... } - c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. - -3. We should still do cast w/w even if `f` is INLINEABLE. E.g. - {- f: Stable unfolding = <stable-big> -} - f = (\xy. <big-body>) |> co - Then we want to w/w to - {- $wf: Stable unfolding = <stable-big> |> sym co -} - $wf = \xy. <big-body> - f = $wf |> co - Notice that the stable unfolding moves to the worker! Now demand analysis - will work fine on $wf, whereas it has trouble with the original f. - c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap. - This point also applies to strong loopbreakers with INLINE pragmas, see - wrinkle (4). - -4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence - hasInlineUnfolding in tryCastWorkerWrapper, which responds False to - loop-breakers) because they'll definitely be inlined anyway, cast and - all. And if we do cast w/w for an INLINE function with arity zero, we get - something really silly: we inline that "worker" right back into the wrapper! - Worse than a no-op, because we have then lost the stable unfolding. - -All these wrinkles are exactly like worker/wrapper for strictness analysis: - f is the wrapper and must inline like crazy - $wf is the worker and must carry f's original pragma -See Note [Worker/wrapper for INLINABLE functions] -and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. - -See #17673, #18093, #18078, #19890. - -Note [Preserve strictness in cast w/w] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the Note [Cast worker/wrapper] transformation, keep the strictness info. -Eg - f = e `cast` co -- f has strictness SSL -When we transform to - f' = e -- f' also has strictness SSL - f = f' `cast` co -- f still has strictness SSL - -Its not wrong to drop it on the floor, but better to keep it. - -Note [Preserve RuntimeRep info in cast w/w] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must not do cast w/w when the presence of the coercion is needed in order -to determine the runtime representation. - -Example: - - Suppose we have a type family: - - type F :: RuntimeRep - type family F where - F = LiftedRep - - together with a type `ty :: TYPE F` and a top-level binding - - a :: ty |> TYPE F[0] - - The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding. - However, were we to apply cast w/w, we would get: - - b :: ty - b = ... - - a :: ty |> TYPE F[0] - a = b `cast` GRefl (TYPE F[0]) - - Now we are in trouble because `ty :: TYPE F` does not have a known runtime - representation, because we need to be able to reduce the nullary type family - application `F` to find that out. - -Conclusion: only do cast w/w when doing so would not lose the RuntimeRep -information. That is, when handling `Cast rhs co`, don't attempt cast w/w -unless the kind of the type of rhs is concrete, in the sense of -Note [Concrete types] in GHC.Tc.Utils.Concrete. --} - -tryCastWorkerWrapper :: SimplEnv -> BindContext - -> InId -> OccInfo - -> OutId -> OutExpr - -> SimplM (SimplFloats, SimplEnv) --- See Note [Cast worker/wrapper] -tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co) - | BC_Let top_lvl is_rec <- bind_cxt -- Not join points - , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform - -- a DFunUnfolding in mk_worker_unfolding - , not (exprIsTrivial rhs) -- Not x = y |> co; Wrinkle 1 - , not (hasInlineUnfolding info) -- Not INLINE things: Wrinkle 4 - , isConcrete (typeKind work_ty) -- Don't peel off a cast if doing so would - -- lose the underlying runtime representation. - -- See Note [Preserve RuntimeRep info in cast w/w] - , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings - -- See Note [OPAQUE pragma] - = do { uniq <- getUniqueM - ; let work_name = mkSystemVarName uniq occ_fs - work_id = mkLocalIdWithInfo work_name Many work_ty work_info - is_strict = isStrictId bndr - - ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict - work_id (emptyFloats env) rhs - - ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs - ; let work_id_w_unf = work_id `setIdUnfolding` work_unf - floats = rhs_floats `addLetFloats` - unitLetFloat (NonRec work_id_w_unf work_rhs) - - triv_rhs = Cast (Var work_id_w_unf) co - - ; if postInlineUnconditionally env bind_cxt bndr occ_info triv_rhs - -- Almost always True, because the RHS is trivial - -- In that case we want to eliminate the binding fast - -- We conservatively use postInlineUnconditionally so that we - -- check all the right things - then do { tick (PostInlineUnconditionally bndr) - ; return ( floats - , extendIdSubst (setInScopeFromF env floats) old_bndr $ - DoneEx triv_rhs Nothing ) } - - else do { wrap_unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs bndr triv_rhs - ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr) - `setIdUnfolding` wrap_unf - floats' = floats `extendFloats` NonRec bndr' triv_rhs - ; return ( floats', setInScopeFromF env floats' ) } } - where - mode = getMode env - occ_fs = getOccFS bndr - work_ty = coercionLKind co - info = idInfo bndr - work_arity = arityInfo info `min` typeArity work_ty - - work_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info - `setCprSigInfo` cprSigInfo info - `setDemandInfo` demandInfo info - `setInlinePragInfo` inlinePragInfo info - `setArityInfo` work_arity - -- We do /not/ want to transfer OccInfo, Rules - -- Note [Preserve strictness in cast w/w] - -- and Wrinkle 2 of Note [Cast worker/wrapper] - - ----------- Worker unfolding ----------- - -- Stable case: if there is a stable unfolding we have to compose with (Sym co); - -- the next round of simplification will do the job - -- Non-stable case: use work_rhs - -- Wrinkle 3 of Note [Cast worker/wrapper] - mk_worker_unfolding top_lvl work_id work_rhs - = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers - unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) - | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) }) - _ -> mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs work_id work_rhs - -tryCastWorkerWrapper env _ _ _ bndr rhs -- All other bindings - = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr - , text "rhs:" <+> ppr rhs ]) - ; return (mkFloatBind env (NonRec bndr rhs)) } - -mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma --- See Note [Cast worker/wrapper] -mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) - = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag] - , inl_sat = Nothing -- in GHC.Core.Opt.WorkWrap - , inl_act = wrap_act -- See Note [Wrapper activation] - , inl_rule = rule_info } -- in GHC.Core.Opt.WorkWrap - -- RuleMatchInfo is (and must be) unaffected - where - -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap - -- But simpler, because we don't need to disable during InitialPhase - wrap_act | isNeverActive act = activateDuringFinal - | otherwise = act - - -{- ********************************************************************* -* * - prepareBinding, prepareRhs, makeTrivial -* * -********************************************************************* -} - -prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool - -> Id -- Used only for its OccName; can be InId or OutId - -> SimplFloats -> OutExpr - -> SimplM (SimplFloats, OutExpr) --- In (prepareBinding ... bndr floats rhs), the binding is really just --- bndr = let floats in rhs --- Maybe we can ANF-ise this binding and float out; e.g. --- bndr = let a = f x in K a a (g x) --- we could float out to give --- a = f x --- tmp = g x --- bndr = K a a tmp --- That's what prepareBinding does --- Precondition: binder is not a JoinId --- Postcondition: the returned SimplFloats contains only let-floats -prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs - = do { -- Never float join-floats out of a non-join let-binding (which this is) - -- So wrap the body in the join-floats right now - -- Hence: rhs_floats1 consists only of let-floats - let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs - - -- rhs_env: add to in-scope set the binders from rhs_floats - -- so that prepareRhs knows what is in scope in rhs - ; let rhs_env = env `setInScopeFromF` rhs_floats1 - - -- Now ANF-ise the remaining rhs - ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl (getOccFS bndr) rhs1 - - -- Finally, decide whether or not to float - ; let all_floats = rhs_floats1 `addLetFloats` anf_floats - ; if doFloatFromRhs (sm_float_enable $ seMode env) top_lvl is_rec strict_bind all_floats rhs2 - then -- Float! - do { tick LetFloatFromLet - ; return (all_floats, rhs2) } - - else -- Abandon floating altogether; revert to original rhs - -- Since we have already built rhs1, we just need to add - -- rhs_floats1 to it - return (emptyFloats env, wrapFloats rhs_floats1 rhs1) } - -{- Note [prepareRhs] -~~~~~~~~~~~~~~~~~~~~ -prepareRhs takes a putative RHS, checks whether it's a PAP or -constructor application and, if so, converts it to ANF, so that the -resulting thing can be inlined more easily. Thus - x = (f a, g b) -becomes - t1 = f a - t2 = g b - x = (t1,t2) - -We also want to deal well cases like this - v = (f e1 `cast` co) e2 -Here we want to make e1,e2 trivial and get - x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 -That's what the 'go' loop in prepareRhs does --} - -prepareRhs :: HasDebugCallStack - => SimplEnv -> TopLevelFlag - -> FastString -- Base for any new variables - -> OutExpr - -> SimplM (LetFloats, OutExpr) --- Transforms a RHS into a better RHS by ANF'ing args --- for expandable RHSs: constructors and PAPs --- e.g x = Just e --- becomes a = e -- 'a' is fresh --- x = Just a --- See Note [prepareRhs] -prepareRhs env top_lvl occ rhs0 - = do { (_is_exp, floats, rhs1) <- go 0 rhs0 - ; return (floats, rhs1) } - where - go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr) - go n_val_args (Cast rhs co) - = do { (is_exp, floats, rhs') <- go n_val_args rhs - ; return (is_exp, floats, Cast rhs' co) } - go n_val_args (App fun (Type ty)) - = do { (is_exp, floats, rhs') <- go n_val_args fun - ; return (is_exp, floats, App rhs' (Type ty)) } - go n_val_args (App fun arg) - = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun - ; if is_exp - then do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg - ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } - else return (False, emptyLetFloats, App fun arg) - } - go n_val_args (Var fun) - = return (is_exp, emptyLetFloats, Var fun) - where - is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP - -- See Note [CONLIKE pragma] in GHC.Types.Basic - -- The definition of is_exp should match that in - -- 'GHC.Core.Opt.OccurAnal.occAnalApp' - - go n_val_args (Tick t rhs) - -- We want to be able to float bindings past this - -- tick. Non-scoping ticks don't care. - | tickishScoped t == NoScope - = do { (is_exp, floats, rhs') <- go n_val_args rhs - ; return (is_exp, floats, Tick t rhs') } - - -- On the other hand, for scoping ticks we need to be able to - -- copy them on the floats, which in turn is only allowed if - -- we can obtain non-counting ticks. - | (not (tickishCounts t) || tickishCanSplit t) - = do { (is_exp, floats, rhs') <- go n_val_args rhs - ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) - floats' = mapLetFloats floats tickIt - ; return (is_exp, floats', Tick t rhs') } - - go _ other - = return (False, emptyLetFloats, other) - -makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec) -makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd }) - = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e - ; return (floats, arg { as_arg = e' }) } -makeTrivialArg _ arg - = return (emptyLetFloats, arg) -- CastBy, TyArg - -makeTrivial :: HasDebugCallStack - => SimplEnv -> TopLevelFlag -> Demand - -> FastString -- ^ A "friendly name" to build the new binder from - -> OutExpr - -> SimplM (LetFloats, OutExpr) --- Binds the expression to a variable, if it's not trivial, returning the variable --- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A] -makeTrivial env top_lvl dmd occ_fs expr - | exprIsTrivial expr -- Already trivial - || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise - -- See Note [Cannot trivialise] - = return (emptyLetFloats, expr) - - | Cast expr' co <- expr - = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr' - ; return (floats, Cast triv_expr co) } - - | otherwise -- 'expr' is not of form (Cast e co) - = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr - ; uniq <- getUniqueM - ; let name = mkSystemVarName uniq occ_fs - var = mkLocalIdWithInfo name Many expr_ty id_info - - -- Now something very like completeBind, - -- but without the postInlineUnconditionally part - ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1 - -- Technically we should extend the in-scope set in 'env' with - -- the 'floats' from prepareRHS; but they are all fresh, so there is - -- no danger of introducing name shadowig in eta expansion - - ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2 - - ; let final_id = addLetBndrInfo var arity_type unf - bind = NonRec final_id expr2 - - ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ]) - ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) } - where - id_info = vanillaIdInfo `setDemandInfo` dmd - expr_ty = exprType expr - mode = getMode env - -bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool --- True iff we can have a binding of this expression at this level --- Precondition: the type is the type of the expression -bindingOk top_lvl expr expr_ty - | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty - | otherwise = True - -{- Note [Cannot trivialise] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - f :: Int -> Addr# - - foo :: Bar - foo = Bar (f 3) - -Then we can't ANF-ise foo, even though we'd like to, because -we can't make a top-level binding for the Addr# (f 3). And if -so we don't want to turn it into - foo = let x = f 3 in Bar x -because we'll just end up inlining x back, and that makes the -simplifier loop. Better not to ANF-ise it at all. - -Literal strings are an exception. - - foo = Ptr "blob"# - -We want to turn this into: - - foo1 = "blob"# - foo = Ptr foo1 - -See Note [Core top-level string literals] in GHC.Core. - -************************************************************************ -* * - Completing a lazy binding -* * -************************************************************************ - -completeBind - * deals only with Ids, not TyVars - * takes an already-simplified binder and RHS - * is used for both recursive and non-recursive bindings - * is used for both top-level and non-top-level bindings - -It does the following: - - tries discarding a dead binding - - tries PostInlineUnconditionally - - add unfolding [this is the only place we add an unfolding] - - add arity - - extend the InScopeSet of the SimplEnv - -It does *not* attempt to do let-to-case. Why? Because it is used for - - top-level bindings (when let-to-case is impossible) - - many situations where the "rhs" is known to be a WHNF - (so let-to-case is inappropriate). - -Nor does it do the atomic-argument thing --} - -completeBind :: SimplEnv - -> BindContext - -> InId -- Old binder - -> OutId -- New binder; can be a JoinId - -> OutExpr -- New RHS - -> SimplM (SimplFloats, SimplEnv) --- completeBind may choose to do its work --- * by extending the substitution (e.g. let x = y in ...) --- * or by adding to the floats in the envt --- --- Binder /can/ be a JoinId --- Precondition: rhs obeys the let-can-float invariant -completeBind env bind_cxt old_bndr new_bndr new_rhs - | isCoVar old_bndr - = case new_rhs of - Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) - _ -> return (mkFloatBind env (NonRec new_bndr new_rhs)) - - | otherwise - = assert (isId new_bndr) $ - do { let old_info = idInfo old_bndr - old_unf = realUnfoldingInfo old_info - occ_info = occInfo old_info - - -- Do eta-expansion on the RHS of the binding - -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils - ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs - - -- Simplify the unfolding - ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr - eta_rhs (idType new_bndr) new_arity old_unf - - ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding - -- See Note [In-scope set as a substitution] - - ; if postInlineUnconditionally env bind_cxt new_bndr_w_info occ_info eta_rhs - - then -- Inline and discard the binding - do { tick (PostInlineUnconditionally old_bndr) - ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs - -- See Note [Use occ-anald RHS in postInlineUnconditionally] - ; simplTrace env "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $ - return ( emptyFloats env - , extendIdSubst env old_bndr $ - DoneEx unf_rhs (isJoinId_maybe new_bndr)) } - -- Use the substitution to make quite, quite sure that the - -- substitution will happen, since we are going to discard the binding - - else -- Keep the binding; do cast worker/wrapper - -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $ - tryCastWorkerWrapper env bind_cxt old_bndr occ_info new_bndr_w_info eta_rhs } - -addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId -addLetBndrInfo new_bndr new_arity_type new_unf - = new_bndr `setIdInfo` info5 - where - new_arity = arityTypeArity new_arity_type - info1 = idInfo new_bndr `setArityInfo` new_arity - - -- Unfolding info: Note [Setting the new unfolding] - info2 = info1 `setUnfoldingInfo` new_unf - - -- Demand info: Note [Setting the demand info] - info3 | isEvaldUnfolding new_unf - = zapDemandInfo info2 `orElse` info2 - | otherwise - = info2 - - -- Bottoming bindings: see Note [Bottoming bindings] - info4 = case getBotArity new_arity_type of - Nothing -> info3 - Just ar -> assert (ar == new_arity) $ - info3 `setDmdSigInfo` mkVanillaDmdSig new_arity botDiv - `setCprSigInfo` mkCprSig new_arity botCpr - - -- Zap call arity info. We have used it by now (via - -- `tryEtaExpandRhs`), and the simplifier can invalidate this - -- information, leading to broken code later (e.g. #13479) - info5 = zapCallArityInfo info4 - - -{- Note [Bottoming bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - let x = error "urk" - in ...(case x of <alts>)... -or - let f = \y. error (y ++ "urk") - in ...(case f "foo" of <alts>)... - -Then we'd like to drop the dead <alts> immediately. So it's good to -propagate the info that x's (or f's) RHS is bottom to x's (or f's) -IdInfo as rapidly as possible. - -We use tryEtaExpandRhs on every binding, and it turns out that the -arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already -does a simple bottoming-expression analysis. So all we need to do -is propagate that info to the binder's IdInfo. - -This showed up in #12150; see comment:16. - -There is a second reason for settting the strictness signature. Consider - let -- f :: <[S]b> - f = \x. error "urk" - in ...(f a b c)... -Then, in GHC.Core.Opt.Arity.findRhsArity we'll use the demand-info on `f` -to eta-expand to - let f = \x y z. error "urk" - in ...(f a b c)... - -But now f's strictness signature has too short an arity; see -GHC.Core.Opt.DmdAnal Note [idArity varies independently of dmdTypeDepth]. -Fortuitously, the same strictness-signature-fixup code -gives the function a new strictness signature with the right number of -arguments. Example in stranal/should_compile/EtaExpansion. - -Note [Setting the demand info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the unfolding is a value, the demand info may -go pear-shaped, so we nuke it. Example: - let x = (a,b) in - case x of (p,q) -> h p q x -Here x is certainly demanded. But after we've nuked -the case, we'll get just - let x = (a,b) in h a b x -and now x is not demanded (I'm assuming h is lazy) -This really happens. Similarly - let f = \x -> e in ...f..f... -After inlining f at some of its call sites the original binding may -(for example) be no longer strictly demanded. -The solution here is a bit ad hoc... - -Note [Use occ-anald RHS in postInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we postInlineUnconditionally 'f in - let f = \x -> x True in ...(f blah)... -then we'd like to inline the /occ-anald/ RHS for 'f'. If we -use the non-occ-anald version, we'll end up with a - ...(let x = blah in x True)... -and hence an extra Simplifier iteration. - -We already /have/ the occ-anald version in the Unfolding for -the Id. Well, maybe not /quite/ always. If the binder is Dead, -postInlineUnconditionally will return True, but we may not have an -unfolding because it's too big. Hence the belt-and-braces `orElse` -in the defn of unf_rhs. The Nothing case probably never happens. - - -************************************************************************ -* * -\subsection[Simplify-simplExpr]{The main function: simplExpr} + Gentle simplification * * ************************************************************************ - -The reason for this OutExprStuff stuff is that we want to float *after* -simplifying a RHS, not before. If we do so naively we get quadratic -behaviour as things float out. - -To see why it's important to do it after, consider this (real) example: - - let t = f x - in fst t -==> - let t = let a = e1 - b = e2 - in (a,b) - in fst t -==> - let a = e1 - b = e2 - t = (a,b) - in - a -- Can't inline a this round, cos it appears twice -==> - e1 - -Each of the ==> steps is a round of simplification. We'd save a -whole round if we float first. This can cascade. Consider - - let f = g d - in \x -> ...f... -==> - let f = let d1 = ..d.. in \y -> e - in \x -> ...f... -==> - let d1 = ..d.. - in \x -> ...(\y ->e)... - -Only in this second round can the \y be applied, and it -might do the same again. --} - -simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr -simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier] - = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType] - ; return (Type ty') } - -simplExpr env expr - = simplExprC env expr (mkBoringStop expr_out_ty) - where - expr_out_ty :: OutType - expr_out_ty = substTy env (exprType expr) - -- NB: Since 'expr' is term-valued, not (Type ty), this call - -- to exprType will succeed. exprType fails on (Type ty). - -simplExprC :: SimplEnv - -> InExpr -- A term-valued expression, never (Type ty) - -> SimplCont - -> SimplM OutExpr - -- Simplify an expression, given a continuation -simplExprC env expr cont - = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $ - do { (floats, expr') <- simplExprF env expr cont - ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ - -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ - -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $ - return (wrapFloats floats expr') } - --------------------------------------------------- -simplExprF :: SimplEnv - -> InExpr -- A term-valued expression, never (Type ty) - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -simplExprF !env e !cont -- See Note [Bangs in the Simplifier] - = {- pprTrace "simplExprF" (vcat - [ ppr e - , text "cont =" <+> ppr cont - , text "inscope =" <+> ppr (seInScope env) - , text "tvsubst =" <+> ppr (seTvSubst env) - , text "idsubst =" <+> ppr (seIdSubst env) - , text "cvsubst =" <+> ppr (seCvSubst env) - ]) $ -} - simplExprF1 env e cont - -simplExprF1 :: SimplEnv -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -simplExprF1 _ (Type ty) cont - = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont) - -- simplExprF does only with term-valued expressions - -- The (Type ty) case is handled separately by simplExpr - -- and by the other callers of simplExprF - -simplExprF1 env (Var v) cont = {-#SCC "simplIdF" #-} simplIdF env v cont -simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont -simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont -simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont -simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont - -simplExprF1 env (App fun arg) cont - = {-#SCC "simplExprF1-App" #-} case arg of - Type ty -> do { -- The argument type will (almost) certainly be used - -- in the output program, so just force it now. - -- See Note [Avoiding space leaks in OutType] - arg' <- simplType env ty - - -- But use substTy, not simplType, to avoid forcing - -- the hole type; it will likely not be needed. - -- See Note [The hole type in ApplyToTy] - ; let hole' = substTy env (exprType fun) - - ; simplExprF env fun $ - ApplyToTy { sc_arg_ty = arg' - , sc_hole_ty = hole' - , sc_cont = cont } } - _ -> - -- Crucially, sc_hole_ty is a /lazy/ binding. It will - -- be forced only if we need to run contHoleType. - -- When these are forced, we might get quadratic behavior; - -- this quadratic blowup could be avoided by drilling down - -- to the function and getting its multiplicities all at once - -- (instead of one-at-a-time). But in practice, we have not - -- observed the quadratic behavior, so this extra entanglement - -- seems not worthwhile. - simplExprF env fun $ - ApplyToVal { sc_arg = arg, sc_env = env - , sc_hole_ty = substTy env (exprType fun) - , sc_dup = NoDup, sc_cont = cont } - -simplExprF1 env expr@(Lam {}) cont - = {-#SCC "simplExprF1-Lam" #-} - simplLam env (zapLambdaBndrs expr n_args) cont - -- zapLambdaBndrs: the issue here is under-saturated lambdas - -- (\x1. \x2. e) arg1 - -- Here x1 might have "occurs-once" occ-info, because occ-info - -- is computed assuming that a group of lambdas is applied - -- all at once. If there are too few args, we must zap the - -- occ-info, UNLESS the remaining binders are one-shot - where - n_args = countArgs cont - -- NB: countArgs counts all the args (incl type args) - -- and likewise drop counts all binders (incl type lambdas) - -simplExprF1 env (Case scrut bndr _ alts) cont - = {-#SCC "simplExprF1-Case" #-} - simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr - , sc_alts = alts - , sc_env = env, sc_cont = cont }) - -simplExprF1 env (Let (Rec pairs) body) cont - | Just pairs' <- joinPointBindings_maybe pairs - = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont - - | otherwise - = {-#SCC "simplRecE" #-} simplRecE env pairs body cont - -simplExprF1 env (Let (NonRec bndr rhs) body) cont - | Type ty <- rhs -- First deal with type lets (let a = Type ty in e) - = {-#SCC "simplExprF1-NonRecLet-Type" #-} - assert (isTyVar bndr) $ - do { ty' <- simplType env ty - ; simplExprF (extendTvSubst env bndr ty') body cont } - - | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs - = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont - - | otherwise - = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) body cont - -{- Note [Avoiding space leaks in OutType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the simplifier is run for multiple iterations, we need to ensure -that any thunks in the output of one simplifier iteration are forced -by the evaluation of the next simplifier iteration. Otherwise we may -retain multiple copies of the Core program and leak a terrible amount -of memory (as in #13426). - -The simplifier is naturally strict in the entire "Expr part" of the -input Core program, because any expression may contain binders, which -we must find in order to extend the SimplEnv accordingly. But types -do not contain binders and so it is tempting to write things like - - simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad! - -This is Bad because the result includes a thunk (substTy env ty) which -retains a reference to the whole simplifier environment; and the next -simplifier iteration will not force this thunk either, because the -line above is not strict in ty. - -So instead our strategy is for the simplifier to fully evaluate -OutTypes when it emits them into the output Core program, for example - - simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good - ; return (Type ty') } - -where the only difference from above is that simplType calls seqType -on the result of substTy. - -However, SimplCont can also contain OutTypes and it's not necessarily -a good idea to force types on the way in to SimplCont, because they -may end up not being used and forcing them could be a lot of wasted -work. T5631 is a good example of this. - -- For ApplyToTy's sc_arg_ty, we force the type on the way in because - the type will almost certainly appear as a type argument in the - output program. - -- For the hole types in Stop and ApplyToTy, we force the type when we - emit it into the output program, after obtaining it from - contResultType. (The hole type in ApplyToTy is only directly used - to form the result type in a new Stop continuation.) -} ---------------------------------- --- Simplify a join point, adding the context. --- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do: --- \x1 .. xn -> e => \x1 .. xn -> E[e] --- Note that we need the arity of the join point, since e may be a lambda --- (though this is unlikely). See Note [Join points and case-of-case]. -simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont - -> SimplM OutExpr -simplJoinRhs env bndr expr cont - | Just arity <- isJoinId_maybe bndr - = do { let (join_bndrs, join_body) = collectNBinders arity expr - mult = contHoleScaling cont - ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs) - ; join_body' <- simplExprC env' join_body cont - ; return $ mkLams join_bndrs' join_body' } - - | otherwise - = pprPanic "simplJoinRhs" (ppr bndr) - ---------------------------------- -simplType :: SimplEnv -> InType -> SimplM OutType - -- Kept monadic just so we can do the seqType - -- See Note [Avoiding space leaks in OutType] -simplType env ty - = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ - seqType new_ty `seq` return new_ty - where - new_ty = substTy env ty - ---------------------------------- -simplCoercionF :: SimplEnv -> InCoercion -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplCoercionF env co cont - = do { co' <- simplCoercion env co - ; rebuild env (Coercion co') cont } - -simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion -simplCoercion env co - = do { opts <- getOptCoercionOpts - ; let opt_co = optCoercion opts (getTCvSubst env) co - ; seqCo opt_co `seq` return opt_co } - ------------------------------------ --- | Push a TickIt context outwards past applications and cases, as --- long as this is a non-scoping tick, to let case and application --- optimisations apply. - -simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplTick env tickish expr cont - -- A scoped tick turns into a continuation, so that we can spot - -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do - -- it this way, then it would take two passes of the simplifier to - -- reduce ((scc t (\x . e)) e'). - -- NB, don't do this with counting ticks, because if the expr is - -- bottom, then rebuildCall will discard the continuation. - --- XXX: we cannot do this, because the simplifier assumes that --- the context can be pushed into a case with a single branch. e.g. --- scc<f> case expensive of p -> e --- becomes --- case expensive of p -> scc<f> e --- --- So I'm disabling this for now. It just means we will do more --- simplifier iterations that necessary in some cases. - --- | tickishScoped tickish && not (tickishCounts tickish) --- = simplExprF env expr (TickIt tickish cont) - - -- For unscoped or soft-scoped ticks, we are allowed to float in new - -- cost, so we simply push the continuation inside the tick. This - -- has the effect of moving the tick to the outside of a case or - -- application context, allowing the normal case and application - -- optimisations to fire. - | tickish `tickishScopesLike` SoftScope - = do { (floats, expr') <- simplExprF env expr cont - ; return (floats, mkTick tickish expr') - } - - -- Push tick inside if the context looks like this will allow us to - -- do a case-of-case - see Note [case-of-scc-of-case] - | Select {} <- cont, Just expr' <- push_tick_inside - = simplExprF env expr' cont - - -- We don't want to move the tick, but we might still want to allow - -- floats to pass through with appropriate wrapping (or not, see - -- wrap_floats below) - --- | not (tickishCounts tickish) || tickishCanSplit tickish - -- = wrap_floats - - | otherwise - = no_floating_past_tick - - where - - -- Try to push tick inside a case, see Note [case-of-scc-of-case]. - push_tick_inside = - case expr0 of - Case scrut bndr ty alts - -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) - _other -> Nothing - where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) - movable t = not (tickishCounts t) || - t `tickishScopesLike` NoScope || - tickishCanSplit t - tickScrut e = foldr mkTick e ticks - -- Alternatives get annotated with all ticks that scope in some way, - -- but we don't want to count entries. - tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope) - ts_scope = map mkNoCount $ - filter (not . (`tickishScopesLike` NoScope)) ticks - - no_floating_past_tick = - do { let (inc,outc) = splitCont cont - ; (floats, expr1) <- simplExprF env expr inc - ; let expr2 = wrapFloats floats expr1 - tickish' = simplTickish env tickish - ; rebuild env (mkTick tickish' expr2) outc - } - --- Alternative version that wraps outgoing floats with the tick. This --- results in ticks being duplicated, as we don't make any attempt to --- eliminate the tick if we re-inline the binding (because the tick --- semantics allows unrestricted inlining of HNFs), so I'm not doing --- this any more. FloatOut will catch any real opportunities for --- floating. --- --- wrap_floats = --- do { let (inc,outc) = splitCont cont --- ; (env', expr') <- simplExprF (zapFloats env) expr inc --- ; let tickish' = simplTickish env tickish --- ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0), --- mkTick (mkNoCount tickish') rhs) --- -- when wrapping a float with mkTick, we better zap the Id's --- -- strictness info and arity, because it might be wrong now. --- ; let env'' = addFloats env (mapFloats env' wrap_float) --- ; rebuild env'' expr' (TickIt tickish' outc) --- } - - - simplTickish env tickish - | Breakpoint ext n ids <- tickish - = Breakpoint ext n (map (getDoneId . substId env) ids) - | otherwise = tickish - - -- Push type application and coercion inside a tick - splitCont :: SimplCont -> (SimplCont, SimplCont) - splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) - where (inc,outc) = splitCont tail - splitCont (CastIt co c) = (CastIt co inc, outc) - where (inc,outc) = splitCont c - splitCont other = (mkBoringStop (contHoleType other), other) +-- | Configuration record for `simplifyExpr`. +-- The values of this datatype are /only/ driven by the demands of that function. +data SimplifyExprOpts = SimplifyExprOpts + { se_fam_inst :: ![FamInst] + , se_mode :: !SimplMode + , se_top_env_cfg :: !TopEnvConfig + } - getDoneId (DoneId id) = id - getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst - getDoneId other = pprPanic "getDoneId" (ppr other) +simplifyExpr :: Logger + -> ExternalUnitCache + -> SimplifyExprOpts + -> CoreExpr + -> IO CoreExpr +-- simplifyExpr is called by the driver to simplify an +-- expression typed in at the interactive prompt +simplifyExpr logger euc opts expr + = withTiming logger (text "Simplify [expr]") (const ()) $ + do { eps <- eucEPS euc ; + ; let fam_envs = ( eps_fam_inst_env eps + , extendFamInstEnvList emptyFamInstEnv $ se_fam_inst opts + ) + simpl_env = mkSimplEnv (se_mode opts) fam_envs + top_env_cfg = se_top_env_cfg opts + read_eps_rules = eps_rule_base <$> eucEPS euc + read_ruleenv = extendRuleEnv emptyRuleEnv <$> read_eps_rules + + ; let sz = exprSize expr + + ; (expr', counts) <- initSmpl logger read_ruleenv top_env_cfg sz $ + simplExprGently simpl_env expr + + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats + "Simplifier statistics" FormatText (pprSimplCount counts) + + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression" + FormatCore + (pprCoreExpr expr') + + ; return expr' + } --- Note [case-of-scc-of-case] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- It's pretty important to be able to transform case-of-case when --- there's an SCC in the way. For example, the following comes up --- in nofib/real/compress/Encode.hs: --- --- case scctick<code_string.r1> --- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje --- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) -> --- (ww1_s13f, ww2_s13g, ww3_s13h) --- } --- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) -> --- tick<code_string.f1> --- (ww_s12Y, --- ww1_s12Z, --- PTTrees.PT --- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf) --- } --- --- We really want this case-of-case to fire, because then the 3-tuple --- will go away (indeed, the CPR optimisation is relying on this --- happening). But the scctick is in the way - we need to push it --- inside to expose the case-of-case. So we perform this --- transformation on the inner case: +simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr +-- Simplifies an expression +-- does occurrence analysis, then simplification +-- and repeats (twice currently) because one pass +-- alone leaves tons of crud. +-- Used (a) for user expressions typed in at the interactive prompt +-- (b) the LHS and RHS of a RULE +-- (c) Template Haskell splices -- --- scctick c (case e of { p1 -> e1; ...; pn -> en }) --- ==> --- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en } --- --- So we've moved a constant amount of work out of the scc to expose --- the case. We only do this when the continuation is interesting: in --- for now, it has to be another Case (maybe generalise this later). - -{- -************************************************************************ -* * -\subsection{The main rebuilder} -* * -************************************************************************ --} - -rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) --- At this point the substitution in the SimplEnv should be irrelevant; --- only the in-scope set matters -rebuild env expr cont - = case cont of - Stop {} -> return (emptyFloats env, expr) - TickIt t cont -> rebuild env (mkTick t expr) cont - CastIt co cont -> rebuild env (mkCast expr co) cont - -- NB: mkCast implements the (Coercion co |> g) optimisation - - Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } - -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont - - StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty } - -> rebuildCall env (addValArgTo fun expr fun_ty ) cont - - StrictBind { sc_bndr = b, sc_body = body, sc_env = se, sc_cont = cont } - -> completeBindX (se `setInScopeFromE` env) b expr body cont - - ApplyToTy { sc_arg_ty = ty, sc_cont = cont} - -> rebuild env (App expr (Type ty)) cont - - ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont} - -- See Note [Avoid redundant simplification] - -> do { (_, _, arg') <- simplArg env dup_flag se arg - ; rebuild env (App expr arg') cont } - -completeBindX :: SimplEnv - -> InId -> OutExpr -- Bind this Id to this (simplified) expression - -- (the let-can-float invariant may not be satisfied) - -> InExpr -- In this lambda - -> SimplCont -- Consumed by this continuation - -> SimplM (SimplFloats, OutExpr) -completeBindX env bndr rhs body cont - | needsCaseBinding (idType bndr) rhs -- Enforcing the let-can-float-invariant - = do { (env1, bndr1) <- simplNonRecBndr env bndr - ; (floats, expr') <- simplLam env1 body cont - -- Do not float floats past the Case binder below - ; let expr'' = wrapFloats floats expr' - ; let case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr''] - ; return (emptyFloats env, case_expr) } +-- The name 'Gently' suggests that the SimplMode is InitialPhase, +-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't +-- enforce that; it just simplifies the expression twice - | otherwise - = do { (floats1, env') <- simplNonRecX env bndr rhs - ; (floats2, expr') <- simplLam env' body cont - ; return (floats1 `addFloats` floats2, expr') } +-- It's important that simplExprGently does eta reduction; see +-- Note [Simplify rule LHS] above. The +-- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam) +-- but only if -O is on. +simplExprGently env expr = do + expr1 <- simplExpr env (occurAnalyseExpr expr) + simplExpr env (occurAnalyseExpr expr1) {- ************************************************************************ * * -\subsection{Lambdas} +\subsection{The driver for the simplifier} * * ************************************************************************ -} -{- Note [Optimising reflexivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important (for compiler performance) to get rid of reflexivity as soon -as it appears. See #11735, #14737, and #15019. - -In particular, we want to behave well on - - * e |> co1 |> co2 - where the two happen to cancel out entirely. That is quite common; - e.g. a newtype wrapping and unwrapping cancel. - - - * (f |> co) @t1 @t2 ... @tn x1 .. xm - Here we will use pushCoTyArg and pushCoValArg successively, which - build up NthCo stacks. Silly to do that if co is reflexive. - -However, we don't want to call isReflexiveCo too much, because it uses -type equality which is expensive on big types (#14737 comment:7). - -A good compromise (determined experimentally) seems to be to call -isReflexiveCo - * when composing casts, and - * at the end - -In investigating this I saw missed opportunities for on-the-fly -coercion shrinkage. See #15090. --} - +-- | Configuration record for `simplifyPgm`. +-- The values of this datatype are /only/ driven by the demands of that function. +data SimplifyOpts = SimplifyOpts + { so_dump_core_sizes :: !Bool + , so_iterations :: !Int + , so_mode :: !SimplMode + , so_pass_result_cfg :: !(Maybe LintPassResultConfig) + , so_rule_base :: !RuleBase + , so_top_env_cfg :: !TopEnvConfig + } -simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplCast env body co0 cont0 - = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 - ; cont1 <- {-#SCC "simplCast-addCoerce" #-} - if isReflCo co1 - then return cont0 -- See Note [Optimising reflexivity] - else addCoerce co1 cont0 - ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } +simplifyPgm :: Logger + -> UnitEnv + -> SimplifyOpts + -> ModGuts + -> IO (SimplCount, ModGuts) -- New bindings + +simplifyPgm logger unit_env opts + guts@(ModGuts { mg_module = this_mod + , mg_rdr_env = rdr_env + , mg_deps = deps + , mg_binds = binds, mg_rules = rules + , mg_fam_inst_env = fam_inst_env }) + = do { (termination_msg, it_count, counts_out, guts') + <- do_iteration 1 [] binds rules + + ; when (logHasDumpFlag logger Opt_D_verbose_core2core + && logHasDumpFlag logger Opt_D_dump_simpl_stats) $ + logDumpMsg logger + "Simplifier statistics for following pass" + (vcat [text termination_msg <+> text "after" <+> ppr it_count + <+> text "iterations", + blankLine, + pprSimplCount counts_out]) + + ; return (counts_out, guts') + } where - -- If the first parameter is MRefl, then simplifying revealed a - -- reflexive coercion. Omit. - addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont - addCoerceM MRefl cont = return cont - addCoerceM (MCo co) cont = addCoerce co cont - - addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont - addCoerce co1 (CastIt co2 cont) -- See Note [Optimising reflexivity] - | isReflexiveCo co' = return cont - | otherwise = addCoerce co' cont - where - co' = mkTransCo co1 co2 - - addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) - | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty - = {-#SCC "addCoerce-pushCoTyArg" #-} - do { tail' <- addCoerceM m_co' tail - ; return (ApplyToTy { sc_arg_ty = arg_ty' - , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } - -- NB! As the cast goes past, the - -- type of the hole changes (#16312) - - -- (f |> co) e ===> (f (e |> co1)) |> co2 - -- where co :: (s1->s2) ~ (t1->t2) - -- co1 :: t1 ~ s1 - -- co2 :: s2 ~ t2 - addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup, sc_cont = tail }) - | Just (m_co1, m_co2) <- pushCoValArg co - , fixed_rep m_co1 - = {-#SCC "addCoerce-pushCoValArg" #-} - do { tail' <- addCoerceM m_co2 tail - ; case m_co1 of { - MRefl -> return (cont { sc_cont = tail' - , sc_hole_ty = coercionLKind co }) ; - -- Avoid simplifying if possible; - -- See Note [Avoiding exponential behaviour] - - MCo co1 -> - do { (dup', arg_se', arg') <- simplArg env dup arg_se arg - -- When we build the ApplyTo we can't mix the OutCoercion - -- 'co' with the InExpr 'arg', so we simplify - -- to make it all consistent. It's a bit messy. - -- But it isn't a common case. - -- Example of use: #995 - ; return (ApplyToVal { sc_arg = mkCast arg' co1 - , sc_env = arg_se' - , sc_dup = dup' - , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } } } - - addCoerce co cont - | isReflexiveCo co = return cont -- Having this at the end makes a huge - -- difference in T12227, for some reason - -- See Note [Optimising reflexivity] - | otherwise = return (CastIt co cont) - - fixed_rep :: MCoercionR -> Bool - fixed_rep MRefl = True - fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co - -- Without this check, we can get an argument which does not - -- have a fixed runtime representation. - -- See Note [Representation polymorphism invariants] in GHC.Core - -- test: typecheck/should_run/EtaExpandLevPoly - -simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr - -> SimplM (DupFlag, StaticEnv, OutExpr) -simplArg env dup_flag arg_env arg - | isSimplified dup_flag - = return (dup_flag, arg_env, arg) - | otherwise - = do { let arg_env' = arg_env `setInScopeFromE` env - ; arg' <- simplExpr arg_env' arg - ; return (Simplified, zapSubstEnv arg_env', arg') } - -- Return a StaticEnv that includes the in-scope set from 'env', - -- because arg' may well mention those variables (#20639) - -{- -************************************************************************ -* * -\subsection{Lambdas} -* * -************************************************************************ --} - -simplLam :: SimplEnv -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont -simplLam env expr cont = simplExprF env expr cont - -simpl_lam :: SimplEnv -> InBndr -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --- Type beta-reduction -simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) - = do { tick (BetaReduction bndr) - ; simplLam (extendTvSubst env bndr arg_ty) body cont } - --- Value beta-reduction -simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_cont = cont, sc_dup = dup }) - | isSimplified dup -- Don't re-simplify if we've simplified it once - -- See Note [Avoiding exponential behaviour] - = do { tick (BetaReduction bndr) - ; completeBindX env bndr arg body cont } - - | otherwise -- See Note [Avoiding exponential behaviour] - = do { tick (BetaReduction bndr) - ; simplNonRecE env bndr (arg, arg_se) body cont } - --- Discard a non-counting tick on a lambda. This may change the --- cost attribution slightly (moving the allocation of the --- lambda elsewhere), but we don't care: optimisation changes --- cost attribution all the time. -simpl_lam env bndr body (TickIt tickish cont) - | not (tickishCounts tickish) - = simpl_lam env bndr body cont - --- Not enough args, so there are real lambdas left to put in the result -simpl_lam env bndr body cont - = do { let (inner_bndrs, inner_body) = collectBinders body - ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs) - ; body' <- simplExpr env' inner_body - ; new_lam <- rebuildLam env' bndrs' body' cont - ; rebuild env' new_lam cont } - -------------- -simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) --- Historically this had a special case for when a lambda-binder --- could have a stable unfolding; --- see Historical Note [Case binders and join points] --- But now it is much simpler! We now only remove unfoldings. --- See Note [Never put `OtherCon` unfoldings on lambda binders] -simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr) - -simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) -simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs - ------------------- -simplNonRecE :: SimplEnv - -> InId -- The binder, always an Id - -- Never a join point - -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) - -> InExpr -- Body of the let/lambda - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --- simplNonRecE is used for --- * non-top-level non-recursive non-join-point lets in expressions --- * beta reduction --- --- simplNonRec env b (rhs, rhs_se) body k --- = let env in --- cont< let b = rhs_se(rhs) in body > --- --- It deals with strict bindings, via the StrictBind continuation, --- which may abort the whole process. --- --- The RHS may not satisfy the let-can-float invariant yet - -simplNonRecE env bndr (rhs, rhs_se) body cont - = assert (isId bndr && not (isJoinId bndr) ) $ - do { (env1, bndr1) <- simplNonRecBndr env bndr - ; let needs_case_binding = needsCaseBinding (idType bndr1) rhs - -- See Note [Dark corner with representation polymorphism] - ; if | not needs_case_binding - , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se -> - do { tick (PreInlineUnconditionally bndr) - ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ - simplLam env' body cont } - - - -- Deal with strict bindings - -- See Note [Dark corner with representation polymorphism] - | isStrictId bndr1 && sm_case_case (getMode env) - || needs_case_binding -> - simplExprF (rhs_se `setInScopeFromE` env) rhs - (StrictBind { sc_bndr = bndr, sc_body = body - , sc_env = env, sc_cont = cont, sc_dup = NoDup }) - - -- Deal with lazy bindings - | otherwise -> - do { (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) - ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se - ; (floats2, expr') <- simplLam env3 body cont - ; return (floats1 `addFloats` floats2, expr') } } - ------------------- -simplRecE :: SimplEnv - -> [(InId, InExpr)] - -> InExpr - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --- simplRecE is used for --- * non-top-level recursive lets in expressions --- Precondition: not a join-point binding -simplRecE env pairs body cont - = do { let bndrs = map fst pairs - ; massert (all (not . isJoinId) bndrs) - ; env1 <- simplRecBndrs env bndrs - -- NB: bndrs' don't have unfoldings or rules - -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs - ; (floats2, expr') <- simplExprF env2 body cont - ; return (floats1 `addFloats` floats2, expr') } - -{- Note [Dark corner with representation polymorphism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In `simplNonRecE`, the call to `needsCaseBinding` or to `isStrictId` will fail -if the binder does not have a fixed runtime representation, e.g. if it is of kind (TYPE r). -So we are careful to call `isStrictId` on the OutId, not the InId, in case we have - ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg) -That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell -if x is lifted or unlifted from that. - -We only get such redexes from the compulsory inlining of a wired-in, -representation-polymorphic function like `rightSection` (see -GHC.Types.Id.Make). Mind you, SimpleOpt should probably have inlined -such compulsory inlinings already, but belt and braces does no harm. - -Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the -Simplifier without first calling SimpleOpt, so anything involving -GHCi or TH and operator sections will fall over if we don't take -care here. - -Note [Avoiding exponential behaviour] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One way in which we can get exponential behaviour is if we simplify a -big expression, and the re-simplify it -- and then this happens in a -deeply-nested way. So we must be jolly careful about re-simplifying -an expression. That is why simplNonRecX does not try -preInlineUnconditionally (unlike simplNonRecE). - -Example: - f BIG, where f has a RULE -Then - * We simplify BIG before trying the rule; but the rule does not fire - * We inline f = \x. x True - * So if we did preInlineUnconditionally we'd re-simplify (BIG True) - -However, if BIG has /not/ already been simplified, we'd /like/ to -simplify BIG True; maybe good things happen. That is why - -* simplLam has - - a case for (isSimplified dup), which goes via simplNonRecX, and - - a case for the un-simplified case, which goes via simplNonRecE - -* We go to some efforts to avoid unnecessarily simplifying ApplyToVal, - in at least two places - - In simplCast/addCoerce, where we check for isReflCo - - In rebuildCall we avoid simplifying arguments before we have to - (see Note [Trying rewrite rules]) - - -************************************************************************ -* * - Join points -* * -********************************************************************* -} - -{- Note [Rules and unfolding for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - simplExpr (join j x = rhs ) cont - ( {- RULE j (p:ps) = blah -} ) - ( {- StableUnfolding j = blah -} ) - (in blah ) - -Then we will push 'cont' into the rhs of 'j'. But we should *also* push -'cont' into the RHS of - * Any RULEs for j, e.g. generated by SpecConstr - * Any stable unfolding for j, e.g. the result of an INLINE pragma - -Simplifying rules and stable-unfoldings happens a bit after -simplifying the right-hand side, so we remember whether or not it -is a join point, and what 'cont' is, in a value of type MaybeJoinCont - -#13900 was caused by forgetting to push 'cont' into the RHS -of a SpecConstr-generated RULE for a join point. --} - -simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr - -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplNonRecJoinPoint env bndr rhs body cont - | assert (isJoinId bndr ) True - , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env - = do { tick (PreInlineUnconditionally bndr) - ; simplExprF env' body cont } - - | otherwise - = wrapJoinCont env cont $ \ env cont -> - do { -- We push join_cont into the join RHS and the body; - -- and wrap wrap_cont around the whole thing - ; let mult = contHoleScaling cont - res_ty = contResultType cont - ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join cont) - ; (floats1, env3) <- simplJoinBind env2 cont bndr bndr2 rhs env - ; (floats2, body') <- simplExprF env3 body cont - ; return (floats1 `addFloats` floats2, body') } - - ------------------- -simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] - -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplRecJoinPoint env pairs body cont - = wrapJoinCont env cont $ \ env cont -> - do { let bndrs = map fst pairs - mult = contHoleScaling cont - res_ty = contResultType cont - ; env1 <- simplRecJoinBndrs env bndrs mult res_ty - -- NB: bndrs' don't have unfoldings or rules - -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 (BC_Join cont) pairs - ; (floats2, body') <- simplExprF env2 body cont - ; return (floats1 `addFloats` floats2, body') } - --------------------- -wrapJoinCont :: SimplEnv -> SimplCont - -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) - -> SimplM (SimplFloats, OutExpr) --- Deal with making the continuation duplicable if necessary, --- and with the no-case-of-case situation. -wrapJoinCont env cont thing_inside - | contIsStop cont -- Common case; no need for fancy footwork - = thing_inside env cont - - | not (sm_case_case (getMode env)) - -- See Note [Join points with -fno-case-of-case] - = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) - ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 - ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont - ; return (floats2 `addFloats` floats3, expr3) } - - | otherwise - -- Normal case; see Note [Join points and case-of-case] - = do { (floats1, cont') <- mkDupableCont env cont - ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' - ; return (floats1 `addFloats` floats2, result) } - - --------------------- -trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont --- Drop outer context from join point invocation (jump) --- See Note [Join points and case-of-case] - -trimJoinCont _ Nothing cont - = cont -- Not a jump -trimJoinCont var (Just arity) cont - = trim arity cont + dump_core_sizes = so_dump_core_sizes opts + mode = so_mode opts + max_iterations = so_iterations opts + hpt_rule_base = so_rule_base opts + top_env_cfg = so_top_env_cfg opts + print_unqual = mkPrintUnqualified unit_env rdr_env + active_rule = activeRule mode + active_unf = activeUnfolding mode + + do_iteration :: Int -- Counts iterations + -> [SimplCount] -- Counts from earlier iterations, reversed + -> CoreProgram -- Bindings in + -> [CoreRule] -- and orphan rules + -> IO (String, Int, SimplCount, ModGuts) + + do_iteration iteration_no counts_so_far binds rules + -- iteration_no is the number of the iteration we are + -- about to begin, with '1' for the first + | iteration_no > max_iterations -- Stop if we've run out of iterations + = warnPprTrace (debugIsOn && (max_iterations > 2)) + "Simplifier bailing out" + ( hang (ppr this_mod <> text ", after" + <+> int max_iterations <+> text "iterations" + <+> (brackets $ hsep $ punctuate comma $ + map (int . simplCountN) (reverse counts_so_far))) + 2 (text "Size =" <+> ppr (coreBindsStats binds))) $ + + -- Subtract 1 from iteration_no to get the + -- number of iterations we actually completed + return ( "Simplifier baled out", iteration_no - 1 + , totalise counts_so_far + , guts { mg_binds = binds, mg_rules = rules } ) + + -- Try and force thunks off the binds; significantly reduces + -- space usage, especially with -O. JRS, 000620. + | let sz = coreBindsSize binds + , () <- sz `seq` () -- Force it + = do { + -- Occurrence analysis + let { tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm this_mod active_unf active_rule rules + binds + } ; + Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" + FormatCore + (pprCoreBindings tagged_binds); + + -- read_eps_rules: + -- We need to read rules from the EPS regularly because simplification can + -- poke on IdInfo thunks, which in turn brings in new rules + -- behind the scenes. Otherwise there's a danger we'll simply + -- miss the rules for Ids hidden inside imported inlinings + -- Hence just before attempting to match rules we read on the EPS + -- value and then combine it when the existing rule base. + -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`. + eps <- ueEPS unit_env ; + let { -- Forcing this value to avoid unnessecary allocations. + -- Not doing so results in +25.6% allocations of LargeRecord. + ; !rule_base = extendRuleBaseList hpt_rule_base rules + ; vis_orphs = this_mod : dep_orphs deps + ; base_ruleenv = mkRuleEnv rule_base vis_orphs + ; read_eps_rules = eps_rule_base <$> ueEPS unit_env + ; read_ruleenv = extendRuleEnv base_ruleenv <$> read_eps_rules + + ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) + ; simpl_env = mkSimplEnv mode fam_envs } ; + + -- Simplify the program + ((binds1, rules1), counts1) <- + initSmpl logger read_ruleenv top_env_cfg sz $ + do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} + simplTopBinds simpl_env tagged_binds + + -- Apply the substitution to rules defined in this module + -- for imported Ids. Eg RULE map my_f = blah + -- If we have a substitution my_f :-> other_f, we'd better + -- apply it to the rule to, or it'll never match + ; rules1 <- simplImpRules env1 rules + + ; return (getTopFloatBinds floats, rules1) } ; + + -- Stop if nothing happened; don't dump output + -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Stats + if isZeroSimplCount counts1 then + return ( "Simplifier reached fixed point", iteration_no + , totalise (counts1 : counts_so_far) -- Include "free" ticks + , guts { mg_binds = binds1, mg_rules = rules1 } ) + else do { + -- Short out indirections + -- We do this *after* at least one run of the simplifier + -- because indirection-shorting uses the export flag on *occurrences* + -- and that isn't guaranteed to be ok until after the first run propagates + -- stuff from the binding site to its occurrences + -- + -- ToDo: alas, this means that indirection-shorting does not happen at all + -- if the simplifier does nothing (not common, I know, but unsavoury) + let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; + + -- Dump the result of this iteration + dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ; + + for_ (so_pass_result_cfg opts) $ \pass_result_cfg -> + lintPassResult logger pass_result_cfg binds2 ; + + -- Loop + do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 + } } +#if __GLASGOW_HASKELL__ <= 810 + | otherwise = panic "do_iteration" +#endif + where + -- Remember the counts_so_far are reversed + totalise :: [SimplCount] -> SimplCount + totalise = foldr (\c acc -> acc `plusSimplCount` c) + (zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats) + +dump_end_iteration :: Logger -> Bool -> PrintUnqualified -> Int + -> SimplCount -> CoreProgram -> [CoreRule] -> IO () +dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts binds rules + = dumpPassResult logger dump_core_sizes print_unqual mb_flag hdr pp_counts binds rules where - trim 0 cont@(Stop {}) - = cont - trim 0 cont - = mkBoringStop (contResultType cont) - trim n cont@(ApplyToVal { sc_cont = k }) - = cont { sc_cont = trim (n-1) k } - trim n cont@(ApplyToTy { sc_cont = k }) - = cont { sc_cont = trim (n-1) k } -- join arity counts types! - trim _ cont - = pprPanic "completeCall" $ ppr var $$ ppr cont - - -{- Note [Join points and case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we perform the case-of-case transform (or otherwise push continuations -inward), we want to treat join points specially. Since they're always -tail-called and we want to maintain this invariant, we can do this (for any -evaluation context E): - - E[join j = e - in case ... of - A -> jump j 1 - B -> jump j 2 - C -> f 3] - - --> - - join j = E[e] - in case ... of - A -> jump j 1 - B -> jump j 2 - C -> E[f 3] - -As is evident from the example, there are two components to this behavior: - - 1. When entering the RHS of a join point, copy the context inside. - 2. When a join point is invoked, discard the outer context. - -We need to be very careful here to remain consistent---neither part is -optional! - -We need do make the continuation E duplicable (since we are duplicating it) -with mkDupableCont. - - -Note [Join points with -fno-case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Supose case-of-case is switched off, and we are simplifying - - case (join j x = <j-rhs> in - case y of - A -> j 1 - B -> j 2 - C -> e) of <outer-alts> - -Usually, we'd push the outer continuation (case . of <outer-alts>) into -both the RHS and the body of the join point j. But since we aren't doing -case-of-case we may then end up with this totally bogus result - - join x = case <j-rhs> of <outer-alts> in - case (case y of - A -> j 1 - B -> j 2 - C -> e) of <outer-alts> - -This would be OK in the language of the paper, but not in GHC: j is no longer -a join point. We can only do the "push continuation into the RHS of the -join point j" if we also push the continuation right down to the /jumps/ to -j, so that it can evaporate there. If we are doing case-of-case, we'll get to - - join x = case <j-rhs> of <outer-alts> in - case y of - A -> j 1 - B -> j 2 - C -> case e of <outer-alts> - -which is great. - -Bottom line: if case-of-case is off, we must stop pushing the continuation -inwards altogether at any join point. Instead simplify the (join ... in ...) -with a Stop continuation, and wrap the original continuation around the -outside. Surprisingly tricky! + mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations + | otherwise = Nothing + -- Show details if Opt_D_dump_simpl_iterations is on + hdr = "Simplifier iteration=" ++ show iteration_no + pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr + , pprSimplCount counts + , text "---- End of simplifier counts for" <+> text hdr ] +{- ************************************************************************ * * - Variables + Shorting out indirections * * ************************************************************************ --} - -simplVar :: SimplEnv -> InVar -> SimplM OutExpr --- Look up an InVar in the environment -simplVar env var - -- Why $! ? See Note [Bangs in the Simplifier] - | isTyVar var = return $! Type $! (substTyVar env var) - | isCoVar var = return $! Coercion $! (substCoVar env var) - | otherwise - = case substId env var of - ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids - in simplExpr env' e - DoneId var1 -> return (Var var1) - DoneEx e _ -> return e - -simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplIdF env var cont - = case substId env var of - ContEx tvs cvs ids e -> - let env' = setSubstEnv env tvs cvs ids - in simplExprF env' e cont - -- Don't trim; haven't already simplified e, - -- so the cont is not embodied in e - DoneId var1 -> - let cont' = trimJoinCont var (isJoinId_maybe var1) cont - in completeCall env var1 cont' - - DoneEx e mb_join -> - let env' = zapSubstEnv env - cont' = trimJoinCont var mb_join cont - in simplExprF env' e cont' - -- Note [zapSubstEnv] - -- ~~~~~~~~~~~~~~~~~~ - -- The template is already simplified, so don't re-substitute. - -- This is VITAL. Consider - -- let x = e in - -- let y = \z -> ...x... in - -- \ x -> ...y... - -- We'll clone the inner \x, adding x->x' in the id_subst - -- Then when we inline y, we must *not* replace x by x' in - -- the inlined copy!! - ---------------------------------------------------------- --- Dealing with a call site - -completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) -completeCall env var cont - | Just expr <- callSiteInline logger uf_opts case_depth var active_unf - lone_variable arg_infos interesting_cont - -- Inline the variable's RHS - = do { checkedTick (UnfoldingDone var) - ; dump_inline expr cont - ; let env1 = zapSubstEnv env - ; simplExprF env1 expr cont } - - | otherwise - -- Don't inline; instead rebuild the call - = do { rule_base <- getSimplRules - ; let rules = getRules rule_base var - info = mkArgInfo env var rules - n_val_args call_cont - ; rebuildCall env info cont } - - where - uf_opts = seUnfoldingOpts env - case_depth = seCaseDepth env - logger = seLogger env - (lone_variable, arg_infos, call_cont) = contArgs cont - n_val_args = length arg_infos - interesting_cont = interestingCallContext env call_cont - active_unf = activeUnfolding (getMode env) var - - log_inlining doc - = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) - Opt_D_dump_inlinings - "" FormatText doc - - dump_inline unfolding cont - | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return () - | not (logHasDumpFlag logger Opt_D_verbose_core2core) - = when (isExternalName (idName var)) $ - log_inlining $ - sep [text "Inlining done:", nest 4 (ppr var)] - | otherwise - = log_inlining $ - sep [text "Inlining done: " <> ppr var, - nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), - text "Cont: " <+> ppr cont])] - -rebuildCall :: SimplEnv - -> ArgInfo - -> SimplCont - -> SimplM (SimplFloats, OutExpr) --- We decided not to inline, so --- - simplify the arguments --- - try rewrite rules --- - and rebuild - ----------- Bottoming applications -------------- -rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont - -- When we run out of strictness args, it means - -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo - -- Then we want to discard the entire strict continuation. E.g. - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - -- Then, especially in the first of these cases, we'd like to discard - -- the continuation, leaving just the bottoming expression. But the - -- type might not be right, so we may have to add a coerce. - | not (contIsTrivial cont) -- Only do this if there is a non-trivial - -- continuation to discard, else we do it - -- again and again! - = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] - return (emptyFloats env, castBottomExpr res cont_ty) - where - res = argInfoExpr fun rev_args - cont_ty = contResultType cont - ----------- Try rewrite RULES -------------- --- See Note [Trying rewrite rules] -rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args - , ai_rules = Just (nr_wanted, rules) }) cont - | nr_wanted == 0 || no_more_args - , let info' = info { ai_rules = Nothing } - = -- We've accumulated a simplified call in <fun,rev_args> - -- so try rewrite rules; see Note [RULES apply to simplified arguments] - -- See also Note [Rules for recursive functions] - do { mb_match <- tryRules env rules fun (reverse rev_args) cont - ; case mb_match of - Just (env', rhs, cont') -> simplExprF env' rhs cont' - Nothing -> rebuildCall env info' cont } - where - no_more_args = case cont of - ApplyToTy {} -> False - ApplyToVal {} -> False - _ -> True - - ----------- Simplify applications and casts -------------- -rebuildCall env info (CastIt co cont) - = rebuildCall env (addCastTo info co) cont - -rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }) - = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont - ----------- The runRW# rule. Do this after absorbing all arguments ------ --- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep. --- --- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o --- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ]) -rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args }) - (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_cont = cont, sc_hole_ty = fun_ty }) - | fun_id `hasKey` runRWKey - , not (contIsStop cont) -- Don't fiddle around if the continuation is boring - , [ TyArg {}, TyArg {} ] <- rev_args - = do { s <- newId (fsLit "s") Many realWorldStatePrimTy - ; let (m,_,_) = splitFunTy fun_ty - env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s] - ty' = contResultType cont - cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s - , sc_env = env', sc_cont = cont - , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } - -- cont' applies to s, then K - ; body' <- simplExprC env' arg cont' - ; let arg' = Lam s body' - rr' = getRuntimeRep ty' - call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] - ; return (emptyFloats env, call') } - -rebuildCall env fun_info - (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup_flag, sc_hole_ty = fun_ty - , sc_cont = cont }) - -- Argument is already simplified - | isSimplified dup_flag -- See Note [Avoid redundant simplification] - = rebuildCall env (addValArgTo fun_info arg fun_ty) cont - - -- Strict arguments - | isStrictArgInfo fun_info - , sm_case_case (getMode env) - = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ - simplExprF (arg_se `setInScopeFromE` env) arg - (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty - , sc_dup = Simplified - , sc_cont = cont }) - -- Note [Shadowing] - - -- Lazy arguments - | otherwise - -- DO NOT float anything outside, hence simplExprC - -- There is no benefit (unlike in a let-binding), and we'd - -- have to be very careful about bogus strictness through - -- floating a demanded let. - = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg - (mkLazyArgStop arg_ty fun_info) - ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } - where - arg_ty = funArgTy fun_ty - - ----------- No further useful info, revert to generic rebuild ------------ -rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont - = rebuild env (argInfoExpr fun rev_args) cont +If we have this: -{- Note [Trying rewrite rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet -simplified. We want to simplify enough arguments to allow the rules -to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone -is sufficient. Example: class ops - (+) dNumInt e2 e3 -If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the -latter's strictness when simplifying e2, e3. Moreover, suppose we have - RULE f Int = \x. x True + x_local = <expression> + ...bindings... + x_exported = x_local -Then given (f Int e1) we rewrite to - (\x. x True) e1 -without simplifying e1. Now we can inline x into its unique call site, -and absorb the True into it all in the same pass. If we simplified -e1 first, we couldn't do that; see Note [Avoiding exponential behaviour]. +where x_exported is exported, and x_local is not, then we replace it with this: -So we try to apply rules if either - (a) no_more_args: we've run out of argument that the rules can "see" - (b) nr_wanted: none of the rules wants any more arguments + x_exported = <expression> + x_local = x_exported + ...bindings... +Without this we never get rid of the x_exported = x_local thing. This +save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and +makes strictness information propagate better. This used to happen in +the final phase, but it's tidier to do it here. -Note [RULES apply to simplified arguments] +Note [Messing up the exported Id's RULES] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very desirable to try RULES once the arguments have been simplified, because -doing so ensures that rule cascades work in one pass. Consider - {-# RULES g (h x) = k x - f (k x) = x #-} - ...f (g (h x))... -Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If -we match f's rules against the un-simplified RHS, it won't match. This -makes a particularly big difference when superclass selectors are involved: - op ($p1 ($p2 (df d))) -We want all this to unravel in one sweep. - -Note [Avoid redundant simplification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because RULES apply to simplified arguments, there's a danger of repeatedly -simplifying already-simplified arguments. An important example is that of - (>>=) d e1 e2 -Here e1, e2 are simplified before the rule is applied, but don't really -participate in the rule firing. So we mark them as Simplified to avoid -re-simplifying them. - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -This part of the simplifier may break the no-shadowing invariant -Consider - f (...(\a -> e)...) (case y of (a,b) -> e') -where f is strict in its second arg -If we simplify the innermost one first we get (...(\a -> e)...) -Simplifying the second arg makes us float the case out, so we end up with - case y of (a,b) -> f (...(\a -> e)...) e' -So the output does not have the no-shadowing invariant. However, there is -no danger of getting name-capture, because when the first arg was simplified -we used an in-scope set that at least mentioned all the variables free in its -static environment, and that is enough. - -We can't just do innermost first, or we'd end up with a dual problem: - case x of (a,b) -> f e (...(\a -> e')...) - -I spent hours trying to recover the no-shadowing invariant, but I just could -not think of an elegant way to do it. The simplifier is already knee-deep in -continuations. We have to keep the right in-scope set around; AND we have -to get the effect that finding (error "foo") in a strict arg position will -discard the entire application and replace it with (error "foo"). Getting -all this at once is TOO HARD! - - -************************************************************************ -* * - Rewrite rules -* * -************************************************************************ --} - -tryRules :: SimplEnv -> [CoreRule] - -> Id -> [ArgSpec] - -> SimplCont - -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) - -tryRules env rules fn args call_cont - | null rules - = return Nothing - -{- Disabled until we fix #8326 - | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#] - , [_type_arg, val_arg] <- args - , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont - , isDeadBinder bndr - = do { let enum_to_tag :: CoreAlt -> CoreAlt - -- Takes K -> e into tagK# -> e - -- where tagK# is the tag of constructor K - enum_to_tag (DataAlt con, [], rhs) - = assert (isEnumerationTyCon (dataConTyCon con) ) - (LitAlt tag, [], rhs) - where - tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG)) - enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt) - - new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts - new_bndr = setIdType bndr intPrimTy - -- The binder is dead, but should have the right type - ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } --} - - | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env) - (activeRule (getMode env)) fn - (argInfoAppArgs args) rules - -- Fire a rule for the function - = do { checkedTick (RuleFired (ruleName rule)) - ; let cont' = pushSimplifiedArgs zapped_env - (drop (ruleArity rule) args) - call_cont - -- (ruleArity rule) says how - -- many args the rule consumed - - occ_anald_rhs = occurAnalyseExpr rule_rhs - -- See Note [Occurrence-analyse after rule firing] - ; dump rule rule_rhs - ; return (Just (zapped_env, occ_anald_rhs, cont')) } - -- The occ_anald_rhs and cont' are all Out things - -- hence zapping the environment - - | otherwise -- No rule fires - = do { nodump -- This ensures that an empty file is written - ; return Nothing } - - where - ropts = initRuleOpts dflags - dflags = seDynFlags env - logger = seLogger env - zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] - - printRuleModule rule - = parens (maybe (text "BUILTIN") - (pprModuleName . moduleName) - (ruleModule rule)) - - dump rule rule_rhs - | logHasDumpFlag logger Opt_D_dump_rule_rewrites - = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat - [ text "Rule:" <+> ftext (ruleName rule) - , text "Module:" <+> printRuleModule rule - , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) - , text "After: " <+> hang (pprCoreExpr rule_rhs) 2 - (sep $ map ppr $ drop (ruleArity rule) args) - , text "Cont: " <+> ppr call_cont ] - - | logHasDumpFlag logger Opt_D_dump_rule_firings - = log_rule Opt_D_dump_rule_firings "Rule fired:" $ - ftext (ruleName rule) - <+> printRuleModule rule +We must be careful about discarding (obviously) or even merging the +RULES on the exported Id. The example that went bad on me at one stage +was this one: - | otherwise - = return () + iterate :: (a -> a) -> a -> [a] + [Exported] + iterate = iterateList - nodump - | logHasDumpFlag logger Opt_D_dump_rule_rewrites - = liftIO $ - touchDumpFile logger Opt_D_dump_rule_rewrites + iterateFB c f x = x `c` iterateFB c f (f x) + iterateList f x = x : iterateList f (f x) + [Not exported] - | logHasDumpFlag logger Opt_D_dump_rule_firings - = liftIO $ - touchDumpFile logger Opt_D_dump_rule_firings + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterateList + #-} - | otherwise - = return () +This got shorted out to: - log_rule flag hdr details - = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText - $ sep [text hdr, nest 4 details] + iterateList :: (a -> a) -> a -> [a] + iterateList = iterate -trySeqRules :: SimplEnv - -> OutExpr -> InExpr -- Scrutinee and RHS - -> SimplCont - -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) --- See Note [User-defined RULES for seq] -trySeqRules in_env scrut rhs cont - = do { rule_base <- getSimplRules - ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont } - where - no_cast_scrut = drop_casts scrut - scrut_ty = exprType no_cast_scrut - seq_id_ty = idType seqId -- forall r a (b::TYPE r). a -> b -> b - res1_ty = piResultTy seq_id_ty rhs_rep -- forall a (b::TYPE rhs_rep). a -> b -> b - res2_ty = piResultTy res1_ty scrut_ty -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b - res3_ty = piResultTy res2_ty rhs_ty -- scrut_ty -> rhs_ty -> rhs_ty - res4_ty = funResultTy res3_ty -- rhs_ty -> rhs_ty - rhs_ty = substTy in_env (exprType rhs) - rhs_rep = getRuntimeRep rhs_ty - out_args = [ TyArg { as_arg_ty = rhs_rep - , as_hole_ty = seq_id_ty } - , TyArg { as_arg_ty = scrut_ty - , as_hole_ty = res1_ty } - , TyArg { as_arg_ty = rhs_ty - , as_hole_ty = res2_ty } - , ValArg { as_arg = no_cast_scrut - , as_dmd = seqDmd - , as_hole_ty = res3_ty } ] - rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs - , sc_env = in_env, sc_cont = cont - , sc_hole_ty = res4_ty } - - -- Lazily evaluated, so we don't do most of this - - drop_casts (Cast e _) = drop_casts e - drop_casts e = e - -{- Note [User-defined RULES for seq] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given - case (scrut |> co) of _ -> rhs -look for rules that match the expression - seq @t1 @t2 scrut -where scrut :: t1 - rhs :: t2 - -If you find a match, rewrite it, and apply to 'rhs'. - -Notice that we can simply drop casts on the fly here, which -makes it more likely that a rule will match. - -See Note [User-defined RULES for seq] in GHC.Types.Id.Make. - -Note [Occurrence-analyse after rule firing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -After firing a rule, we occurrence-analyse the instantiated RHS before -simplifying it. Usually this doesn't make much difference, but it can -be huge. Here's an example (simplCore/should_compile/T7785) - - map f (map f (map f xs) - -= -- Use build/fold form of map, twice - map f (build (\cn. foldr (mapFB c f) n - (build (\cn. foldr (mapFB c f) n xs)))) - -= -- Apply fold/build rule - map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n)) - -= -- Beta-reduce - -- Alas we have no occurrence-analysed, so we don't know - -- that c is used exactly once - map f (build (\cn. let c1 = mapFB c f in - foldr (mapFB c1 f) n xs)) + iterateFB c f x = x `c` iterateFB c f (f x) + iterate f x = x : iterate f (f x) -= -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g) - -- We can do this because (mapFB c n) is a PAP and hence expandable - map f (build (\cn. let c1 = mapFB c n in - foldr (mapFB c (f.f)) n x)) + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterate + #-} -This is not too bad. But now do the same with the outer map, and -we get another use of mapFB, and t can interact with /both/ remaining -mapFB calls in the above expression. This is stupid because actually -that 'c1' binding is dead. The outer map introduces another c2. If -there is a deep stack of maps we get lots of dead bindings, and lots -of redundant work as we repeatedly simplify the result of firing rules. +And now we get an infinite loop in the rule system + iterate f x -> build (\cn -> iterateFB c f x) + -> iterateFB (:) f x + -> iterate f x -The easy thing to do is simply to occurrence analyse the result of -the rule firing. Note that this occ-anals not only the RHS of the -rule, but also the function arguments, which by now are OutExprs. -E.g. - RULE f (g x) = x+1 +Old "solution": + use rule switching-off pragmas to get rid + of iterateList in the first place -Call f (g BIG) --> (\x. x+1) BIG +But in principle the user *might* want rules that only apply to the Id +they say. And inline pragmas are similar + {-# NOINLINE f #-} + f = local + local = <stuff> +Then we do not want to get rid of the NOINLINE. -The rule binders are lambda-bound and applied to the OutExpr arguments -(here BIG) which lack all internal occurrence info. +Hence hasShortableIdinfo. -Is this inefficient? Not really: we are about to walk over the result -of the rule firing to simplify it, so occurrence analysis is at most -a constant factor. -Possible improvement: occ-anal the rules when putting them in the -database; and in the simplifier just occ-anal the OutExpr arguments. -But that's more complicated and the rule RHS is usually tiny; so I'm -just doing the simple thing. - -Historical note: previously we did occ-anal the rules in Rule.hs, -but failed to occ-anal the OutExpr arguments, which led to the -nasty performance problem described above. - - -Note [Optimising tagToEnum#] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an enumeration data type: - - data Foo = A | B | C - -Then we want to transform - - case tagToEnum# x of ==> case x of - A -> e1 DEFAULT -> e1 - B -> e2 1# -> e2 - C -> e3 2# -> e3 - -thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT -alternative we retain it (remember it comes first). If not the case must -be exhaustive, and we reflect that in the transformed version by adding -a DEFAULT. Otherwise Lint complains that the new case is not exhaustive. -See #8317. - -Note [Rules for recursive functions] +Note [Rules and indirection-zapping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might think that we shouldn't apply rules for a loop breaker: -doing so might give rise to an infinite loop, because a RULE is -rather like an extra equation for the function: - RULE: f (g x) y = x+y - Eqn: f a y = a-y - -But it's too drastic to disable rules for loop breakers. -Even the foldr/build rule would be disabled, because foldr -is recursive, and hence a loop breaker: - foldr k z (build g) = g k z -So it's up to the programmer: rules can cause divergence - - -************************************************************************ -* * - Rebuilding a case expression -* * -************************************************************************ - -Note [Case elimination] -~~~~~~~~~~~~~~~~~~~~~~~ -The case-elimination transformation discards redundant case expressions. -Start with a simple situation: - - case x# of ===> let y# = x# in e - y# -> e - -(when x#, y# are of primitive type, of course). We can't (in general) -do this for algebraic cases, because we might turn bottom into -non-bottom! - -The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise -this idea to look for a case where we're scrutinising a variable, and we know -that only the default case can match. For example: - - case x of - 0# -> ... - DEFAULT -> ...(case x of - 0# -> ... - DEFAULT -> ...) ... - -Here the inner case is first trimmed to have only one alternative, the -DEFAULT, after which it's an instance of the previous case. This -really only shows up in eliminating error-checking code. - -Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs. So - - case e of ===> case e of DEFAULT -> r - True -> r - False -> r - -Now again the case may be eliminated by the CaseElim transformation. -This includes things like (==# a# b#)::Bool so that we simplify - case ==# a# b# of { True -> x; False -> x } -to just - x -This particular example shows up in default methods for -comparison operations (e.g. in (>=) for Int.Int32) - -Note [Case to let transformation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a case over a lifted type has a single alternative, and is being -used as a strict 'let' (all isDeadBinder bndrs), we may want to do -this transformation: - - case e of r ===> let r = e in ...r... - _ -> ...r... - -We treat the unlifted and lifted cases separately: - -* Unlifted case: 'e' satisfies exprOkForSpeculation - (ok-for-spec is needed to satisfy the let-can-float invariant). - This turns case a +# b of r -> ...r... - into let r = a +# b in ...r... - and thence .....(a +# b).... - - However, if we have - case indexArray# a i of r -> ...r... - we might like to do the same, and inline the (indexArray# a i). - But indexArray# is not okForSpeculation, so we don't build a let - in rebuildCase (lest it get floated *out*), so the inlining doesn't - happen either. Annoying. - -* Lifted case: we need to be sure that the expression is already - evaluated (exprIsHNF). If it's not already evaluated - - we risk losing exceptions, divergence or - user-specified thunk-forcing - - even if 'e' is guaranteed to converge, we don't want to - create a thunk (call by need) instead of evaluating it - right away (call by value) - - However, we can turn the case into a /strict/ let if the 'r' is - used strictly in the body. Then we won't lose divergence; and - we won't build a thunk because the let is strict. - See also Note [Case-to-let for strictly-used binders] - -Note [Case-to-let for strictly-used binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have this: - case <scrut> of r { _ -> ..r.. } - -where 'r' is used strictly in (..r..), we can safely transform to - let r = <scrut> in ...r... - -This is a Good Thing, because 'r' might be dead (if the body just -calls error), or might be used just once (in which case it can be -inlined); or we might be able to float the let-binding up or down. -E.g. #15631 has an example. - -Note that this can change the error behaviour. For example, we might -transform - case x of { _ -> error "bad" } - --> error "bad" -which is might be puzzling if 'x' currently lambda-bound, but later gets -let-bound to (error "good"). - -Nevertheless, the paper "A semantics for imprecise exceptions" allows -this transformation. If you want to fix the evaluation order, use -'pseq'. See #8900 for an example where the loss of this -transformation bit us in practice. - -See also Note [Empty case alternatives] in GHC.Core. - -Historical notes - -There have been various earlier versions of this patch: - -* By Sept 18 the code looked like this: - || scrut_is_demanded_var scrut - - scrut_is_demanded_var :: CoreExpr -> Bool - scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s - scrut_is_demanded_var (Var _) = isStrUsedDmd (idDemandInfo case_bndr) - scrut_is_demanded_var _ = False - - This only fired if the scrutinee was a /variable/, which seems - an unnecessary restriction. So in #15631 I relaxed it to allow - arbitrary scrutinees. Less code, less to explain -- but the change - had 0.00% effect on nofib. - -* Previously, in Jan 13 the code looked like this: - || case_bndr_evald_next rhs - - case_bndr_evald_next :: CoreExpr -> Bool - -- See Note [Case binder next] - case_bndr_evald_next (Var v) = v == case_bndr - case_bndr_evald_next (Cast e _) = case_bndr_evald_next e - case_bndr_evald_next (App e _) = case_bndr_evald_next e - case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e - case_bndr_evald_next _ = False - - This patch was part of fixing #7542. See also - Note [Eta reduction soundness], criterion (E) in GHC.Core.Utils.) - - -Further notes about case elimination -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: test :: Integer -> IO () - test = print - -Turns out that this compiles to: - Print.test - = \ eta :: Integer - eta1 :: Void# -> - case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> - case hPutStr stdout - (PrelNum.jtos eta ($w[] @ Char)) - eta1 - of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} - -Notice the strange '<' which has no effect at all. This is a funny one. -It started like this: - -f x y = if x < 0 then jtos x - else if y==0 then "" else jtos x - -At a particular call site we have (f v 1). So we inline to get - - if v < 0 then jtos x - else if 1==0 then "" else jtos x - -Now simplify the 1==0 conditional: - - if v<0 then jtos v else jtos v - -Now common-up the two branches of the case: - - case (v<0) of DEFAULT -> jtos v - -Why don't we drop the case? Because it's strict in v. It's technically -wrong to drop even unnecessary evaluations, and in practice they -may be a result of 'seq' so we *definitely* don't want to drop those. -I don't really know how to improve this situation. - - -Note [FloatBinds from constructor wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have FloatBinds coming from the constructor wrapper -(as in Note [exprIsConApp_maybe on data constructors with wrappers]), -we cannot float past them. We'd need to float the FloatBind -together with the simplify floats, unfortunately the -simplifier doesn't have case-floats. The simplest thing we can -do is to wrap all the floats here. The next iteration of the -simplifier will take care of all these cases and lets. - -Given data T = MkT !Bool, this allows us to simplify -case $WMkT b of { MkT x -> f x } -to -case b of { b' -> f b' }. - -We could try and be more clever (like maybe wfloats only contain -let binders, so we could float them). But the need for the -extra complication is not clear. - -Note [Do not duplicate constructor applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#20125) - let x = (a,b) - in ...(case x of x' -> blah)...x...x... - -We want that `case` to vanish (since `x` is bound to a data con) leaving - let x = (a,b) - in ...(let x'=x in blah)...x..x... - -In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`, -since is bound to (a,b). But in eliminating the case, if the scrutinee -is trivial, we want to bind the case-binder to the scrutinee, /not/ to -the constructor application. Hence the case_bndr_rhs in rebuildCase. - -This applies equally to a non-DEFAULT case alternative, say - let x = (a,b) in ...(case x of x' { (p,q) -> blah })... -This variant is handled by bind_case_bndr in knownCon. - -We want to bind x' to x, and not to a duplicated (a,b)). --} - ---------------------------------------------------------- --- Eliminate the case if possible - -rebuildCase, reallyRebuildCase - :: SimplEnv - -> OutExpr -- Scrutinee - -> InId -- Case binder - -> [InAlt] -- Alternatives (increasing order) - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --------------------------------------------------- --- 1. Eliminate the case if there's a known constructor --------------------------------------------------- - -rebuildCase env scrut case_bndr alts cont - | Lit lit <- scrut -- No need for same treatment as constructors - -- because literals are inlined more vigorously - , not (litIsLifted lit) - = do { tick (KnownBranch case_bndr) - ; case findAlt (LitAlt lit) alts of - Nothing -> missingAlt env case_bndr alts cont - Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs } - - | Just (in_scope', wfloats, con, ty_args, other_args) - <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut - -- Works when the scrutinee is a variable with a known unfolding - -- as well as when it's an explicit constructor application - , let env0 = setInScopeSet env in_scope' - = do { tick (KnownBranch case_bndr) - ; let scaled_wfloats = map scale_float wfloats - -- case_bndr_unf: see Note [Do not duplicate constructor applications] - case_bndr_rhs | exprIsTrivial scrut = scrut - | otherwise = con_app - con_app = Var (dataConWorkId con) `mkTyApps` ty_args - `mkApps` other_args - ; case findAlt (DataAlt con) alts of - Nothing -> missingAlt env0 case_bndr alts cont - Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs - Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args - other_args case_bndr bs rhs cont - } - where - simple_rhs env wfloats case_bndr_rhs bs rhs = - assert (null bs) $ - do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs - -- scrut is a constructor application, - -- hence satisfies let-can-float invariant - ; (floats2, expr') <- simplExprF env' rhs cont - ; case wfloats of - [] -> return (floats1 `addFloats` floats2, expr') - _ -> return - -- See Note [FloatBinds from constructor wrappers] - ( emptyFloats env, - GHC.Core.Make.wrapFloats wfloats $ - wrapFloats (floats1 `addFloats` floats2) expr' )} - - -- This scales case floats by the multiplicity of the continuation hole (see - -- Note [Scaling in case-of-case]). Let floats are _not_ scaled, because - -- they are aliases anyway. - scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) = - let - scale_id id = scaleVarBy holeScaling id - in - GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) - scale_float f = f - - holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr - -- We are in the following situation - -- case[p] case[q] u of { D x -> C v } of { C x -> w } - -- And we are producing case[??] u of { D x -> w[x\v]} - -- - -- What should the multiplicity `??` be? In order to preserve the usage of - -- variables in `u`, it needs to be `pq`. - -- - -- As an illustration, consider the following - -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) } - -- Where C :: A %1 -> T is linear - -- If we were to produce a case[1], like the inner case, we would get - -- case[1] of { C x -> (x, x) } - -- Which is ill-typed with respect to linearity. So it needs to be a - -- case[Many]. - --------------------------------------------------- --- 2. Eliminate the case if scrutinee is evaluated --------------------------------------------------- - -rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont - -- See if we can get rid of the case altogether - -- See Note [Case elimination] - -- mkCase made sure that if all the alternatives are equal, - -- then there is now only one (DEFAULT) rhs - - -- 2a. Dropping the case altogether, if - -- a) it binds nothing (so it's really just a 'seq') - -- b) evaluating the scrutinee has no side effects - | is_plain_seq - , exprOkForSideEffects scrut - -- The entire case is dead, so we can drop it - -- if the scrutinee converges without having imperative - -- side effects or raising a Haskell exception - -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps - = simplExprF env rhs cont - - -- 2b. Turn the case into a let, if - -- a) it binds only the case-binder - -- b) unlifted case: the scrutinee is ok-for-speculation - -- lifted case: the scrutinee is in HNF (or will later be demanded) - -- See Note [Case to let transformation] - | all_dead_bndrs - , doCaseToLet scrut case_bndr - = do { tick (CaseElim case_bndr) - ; (floats1, env') <- simplNonRecX env case_bndr scrut - ; (floats2, expr') <- simplExprF env' rhs cont - ; return (floats1 `addFloats` floats2, expr') } - - -- 2c. Try the seq rules if - -- a) it binds only the case binder - -- b) a rule for seq applies - -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make - | is_plain_seq - = do { mb_rule <- trySeqRules env scrut rhs cont - ; case mb_rule of - Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' - Nothing -> reallyRebuildCase env scrut case_bndr alts cont } - where - all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] - is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect - -rebuildCase env scrut case_bndr alts cont - = reallyRebuildCase env scrut case_bndr alts cont - - -doCaseToLet :: OutExpr -- Scrutinee - -> InId -- Case binder - -> Bool --- The situation is case scrut of b { DEFAULT -> body } --- Can we transform thus? let { b = scrut } in body -doCaseToLet scrut case_bndr - | isTyCoVar case_bndr -- Respect GHC.Core - = isTyCoArg scrut -- Note [Core type and coercion invariant] - - | isUnliftedType (exprType scrut) - -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase). - -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr' - -- (which is an 'InId'): see Note [Dark corner with representation polymorphism]. - -- Using `exprType` is typically cheap becuase `scrut` is typically a variable. - -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts - -- the brain more. Consider that if this test ever turns out to be a perf - -- problem (which seems unlikely). - = exprOkForSpeculation scrut - - | otherwise -- Scrut has a lifted type - = exprIsHNF scrut - || isStrUsedDmd (idDemandInfo case_bndr) - -- See Note [Case-to-let for strictly-used binders] - --------------------------------------------------- --- 3. Catch-all case --------------------------------------------------- - -reallyRebuildCase env scrut case_bndr alts cont - | not (sm_case_case (getMode env)) - = do { case_expr <- simplAlts env scrut case_bndr alts - (mkBoringStop (contHoleType cont)) - ; rebuild env case_expr cont } - - | otherwise - = do { (floats, env', cont') <- mkDupableCaseCont env alts cont - ; case_expr <- simplAlts env' scrut - (scaleIdBy holeScaling case_bndr) - (scaleAltsBy holeScaling alts) - cont' - ; return (floats, case_expr) } - where - holeScaling = contHoleScaling cont - -- Note [Scaling in case-of-case] - -{- -simplCaseBinder checks whether the scrutinee is a variable, v. If so, -try to eliminate uses of v in the RHSs in favour of case_bndr; that -way, there's a chance that v will now only be used once, and hence -inlined. - -Historical note: we use to do the "case binder swap" in the Simplifier -so there were additional complications if the scrutinee was a variable. -Now the binder-swap stuff is done in the occurrence analyser; see -"GHC.Core.Opt.OccurAnal" Note [Binder swap]. - -Note [knownCon occ info] -~~~~~~~~~~~~~~~~~~~~~~~~ -If the case binder is not dead, then neither are the pattern bound -variables: - case <any> of x { (a,b) -> - case x of { (p,q) -> p } } -Here (a,b) both look dead, but come alive after the inner case is eliminated. -The point is that we bring into the envt a binding - let x = (a,b) -after the outer case, and that makes (a,b) alive. At least we do unless -the case binder is guaranteed dead. - -Note [Case alternative occ info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are simply reconstructing a case (the common case), we always -zap the occurrence info on the binders in the alternatives. Even -if the case binder is dead, the scrutinee is usually a variable, and *that* -can bring the case-alternative binders back to life. -See Note [Add unfolding for scrutinee] - -Note [Improving seq] -~~~~~~~~~~~~~~~~~~~ -Consider - type family F :: * -> * - type instance F Int = Int - -We'd like to transform - case e of (x :: F Int) { DEFAULT -> rhs } -===> - case e `cast` co of (x'::Int) - I# x# -> let x = x' `cast` sym co - in rhs - -so that 'rhs' can take advantage of the form of x'. Notice that Note -[Case of cast] (in OccurAnal) may then apply to the result. - -We'd also like to eliminate empty types (#13468). So if - - data Void - type instance F Bool = Void - -then we'd like to transform - case (x :: F Bool) of { _ -> error "urk" } -===> - case (x |> co) of (x' :: Void) of {} - -Nota Bene: we used to have a built-in rule for 'seq' that dropped -casts, so that - case (x |> co) of { _ -> blah } -dropped the cast; in order to improve the chances of trySeqRules -firing. But that works in the /opposite/ direction to Note [Improving -seq] so there's a danger of flip/flopping. Better to make trySeqRules -insensitive to the cast, which is now is. - -The need for [Improving seq] showed up in Roman's experiments. Example: - foo :: F Int -> Int -> Int - foo t n = t `seq` bar n - where - bar 0 = 0 - bar n = bar (n - case t of TI i -> i) -Here we'd like to avoid repeated evaluating t inside the loop, by -taking advantage of the `seq`. - -At one point I did transformation in LiberateCase, but it's more -robust here. (Otherwise, there's a danger that we'll simply drop the -'seq' altogether, before LiberateCase gets to see it.) - -Note [Scaling in case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When two cases commute, if done naively, the multiplicities will be wrong: - - case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many] - { (z[Many], t[Many]) -> z - } - -The multiplicities here, are correct, but if I perform a case of case: - - case u of w[1] - { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } - } - -This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and -`y` must have multiplicities `Many` not `1`! The correct solution is to make -all the `1`-s be `Many`-s instead: - - case u of w[Many] - { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } - } - -In general, when commuting two cases, the rule has to be: - - case (case … of x[p] {…}) of y[q] { … } - ===> case … of x[p*q] { … case … of y[q] { … } } - -This is materialised, in the simplifier, by the fact that every time we simplify -case alternatives with a continuation (the surrounded case (or more!)), we must -scale the entire case we are simplifying, by a scaling factor which can be -computed in the continuation (with function `contHoleScaling`). --} - -simplAlts :: SimplEnv - -> OutExpr -- Scrutinee - -> InId -- Case binder - -> [InAlt] -- Non-empty - -> SimplCont - -> SimplM OutExpr -- Returns the complete simplified case expression - -simplAlts env0 scrut case_bndr alts cont' - = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr - , text "cont':" <+> ppr cont' - , text "in_scope" <+> ppr (seInScope env0) ]) - ; (env1, case_bndr1) <- simplBinder env0 case_bndr - ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding - env2 = modifyInScope env1 case_bndr2 - -- See Note [Case binder evaluated-ness] - - ; fam_envs <- getFamEnvs - ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut - case_bndr case_bndr2 alts - - ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts - -- NB: it's possible that the returned in_alts is empty: this is handled - -- by the caller (rebuildCase) in the missingAlt function - - ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts --- ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return () - - ; let alts_ty' = contResultType cont' - -- See Note [Avoiding space leaks in OutType] - ; seqType alts_ty' `seq` - mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' } - - ------------------------------------- -improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv - -> OutExpr -> InId -> OutId -> [InAlt] - -> SimplM (SimplEnv, OutExpr, OutId) --- Note [Improving seq] -improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _] - | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId (fsLit "nt") Many ty2 - ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing - env2 = extendIdSubst env case_bndr rhs - ; return (env2, scrut `Cast` co, case_bndr2) } - -improveSeq _ env scrut _ case_bndr1 _ - = return (env, scrut, case_bndr1) - - ------------------------------------- -simplAlt :: SimplEnv - -> Maybe OutExpr -- The scrutinee - -> [AltCon] -- These constructors can't be present when - -- matching the DEFAULT alternative - -> OutId -- The case binder - -> SimplCont - -> InAlt - -> SimplM OutAlt - -simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs) - = assert (null bndrs) $ - do { let env' = addBinderUnfolding env case_bndr' - (mkOtherCon imposs_deflt_cons) - -- Record the constructors that the case-binder *can't* be. - ; rhs' <- simplExprC env' rhs cont' - ; return (Alt DEFAULT [] rhs') } - -simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs) - = assert (null bndrs) $ - do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) - ; rhs' <- simplExprC env' rhs cont' - ; return (Alt (LitAlt lit) [] rhs') } - -simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs) - = do { -- See Note [Adding evaluatedness info to pattern-bound variables] - let vs_with_evals = addEvals scrut' con vs - ; (env', vs') <- simplBinders env vs_with_evals - - -- Bind the case-binder to (con args) - ; let inst_tys' = tyConAppArgs (idType case_bndr') - con_app :: OutExpr - con_app = mkConApp2 con inst_tys' vs' - - ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app - ; rhs' <- simplExprC env'' rhs cont' - ; return (Alt (DataAlt con) vs' rhs') } - -{- Note [Adding evaluatedness info to pattern-bound variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -addEvals records the evaluated-ness of the bound variables of -a case pattern. This is *important*. Consider - - data T = T !Int !Int - - case x of { T a b -> T (a+1) b } - -We really must record that b is already evaluated so that we don't -go and re-evaluate it when constructing the result. -See Note [Data-con worker strictness] in GHC.Core.DataCon - -NB: simplLamBndrs preserves this eval info - -In addition to handling data constructor fields with !s, addEvals -also records the fact that the result of seq# is always in WHNF. -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. Example (#15226): - - case seq# v s of - (# s', v' #) -> E - -we want the compiler to be aware that v' is in WHNF in E. - -Open problem: we don't record that v itself is in WHNF (and we can't -do it here). The right thing is to do some kind of binder-swap; -see #15226 for discussion. --} - -addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id] --- See Note [Adding evaluatedness info to pattern-bound variables] -addEvals scrut con vs - -- Deal with seq# applications - | Just scr <- scrut - , isUnboxedTupleDataCon con - , [s,x] <- vs - -- Use stripNArgs rather than collectArgsTicks to avoid building - -- a list of arguments only to throw it away immediately. - , Just (Var f) <- stripNArgs 4 scr - , Just SeqOp <- isPrimOpId_maybe f - , let x' = zapIdOccInfoAndSetEvald MarkedStrict x - = [s, x'] - - -- Deal with banged datacon fields -addEvals _scrut con vs = go vs the_strs - where - the_strs = dataConRepStrictness con - - go [] [] = [] - go (v:vs') strs | isTyVar v = v : go vs' strs - go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs - go _ _ = pprPanic "Simplify.addEvals" - (ppr con $$ - ppr vs $$ - ppr_with_length (map strdisp the_strs) $$ - ppr_with_length (dataConRepArgTys con) $$ - ppr_with_length (dataConRepStrictness con)) - where - ppr_with_length list - = ppr list <+> parens (text "length =" <+> ppr (length list)) - strdisp MarkedStrict = text "MarkedStrict" - strdisp NotMarkedStrict = text "NotMarkedStrict" - -zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id -zapIdOccInfoAndSetEvald str v = - setCaseBndrEvald str $ -- Add eval'dness info - zapIdOccInfo v -- And kill occ info; - -- see Note [Case alternative occ info] - -addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv -addAltUnfoldings env scrut case_bndr con_app - = do { let con_app_unf = mk_simple_unf con_app - env1 = addBinderUnfolding env case_bndr con_app_unf - - -- See Note [Add unfolding for scrutinee] - env2 | Many <- idMult case_bndr = case scrut of - Just (Var v) -> addBinderUnfolding env1 v con_app_unf - Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ - mk_simple_unf (Cast con_app (mkSymCo co)) - _ -> env1 - | otherwise = env1 - - ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) - ; return env2 } - where - -- Force the opts, so that the whole SimplEnv isn't retained - !opts = seUnfoldingOpts env - mk_simple_unf = mkSimpleUnfolding opts - -addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv -addBinderUnfolding env bndr unf - | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf - = warnPprTrace (not (eqType (idType bndr) (exprType tmpl))) - "unfolding type mismatch" - (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $ - modifyInScope env (bndr `setIdUnfolding` unf) - - | otherwise - = modifyInScope env (bndr `setIdUnfolding` unf) +Problem: what if x_exported has a RULE that mentions something in ...bindings...? +Then the things mentioned can be out of scope! Solution + a) Make sure that in this pass the usage-info from x_exported is + available for ...bindings... + b) If there are any such RULES, rec-ify the entire top-level. + It'll get sorted out next time round + +Other remarks +~~~~~~~~~~~~~ +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then we do one only: +\begin{verbatim} + x_local = .... + x_exported1 = x_local + x_exported2 = x_local +==> + x_exported1 = .... -zapBndrOccInfo :: Bool -> Id -> Id --- Consider case e of b { (a,b) -> ... } --- Then if we bind b to (a,b) in "...", and b is not dead, --- then we must zap the deadness info on a,b -zapBndrOccInfo keep_occ_info pat_id - | keep_occ_info = pat_id - | otherwise = zapIdOccInfo pat_id + x_exported2 = x_exported1 +\end{verbatim} -{- Note [Case binder evaluated-ness] +We rely on prior eta reduction to simplify things like +\begin{verbatim} + x_exported = /\ tyvars -> x_local tyvars +==> + x_exported = x_local +\end{verbatim} +Hence,there's a possibility of leaving unchanged something like this: +\begin{verbatim} + x_local = .... + x_exported1 = x_local Int +\end{verbatim} +By the time we've thrown away the types in STG land this +could be eliminated. But I don't think it's very common +and it's dangerous to do this fiddling in STG land +because we might eliminate a binding that's mentioned in the +unfolding for something. + +Note [Indirection zapping and ticks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pin on a (OtherCon []) unfolding to the case-binder of a Case, -even though it'll be over-ridden in every case alternative with a more -informative unfolding. Why? Because suppose a later, less clever, pass -simply replaces all occurrences of the case binder with the binder itself; -then Lint may complain about the let-can-float invariant. Example - case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in .... - ; K -> blah } - -The let-can-float invariant requires that y is evaluated in the call to -reallyUnsafePtrEquality#, which it is. But we still want that to be true if we -propagate binders to occurrences. - -This showed up in #13027. - -Note [Add unfolding for scrutinee] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general it's unlikely that a variable scrutinee will appear -in the case alternatives case x of { ...x unlikely to appear... } -because the binder-swap in OccurAnal has got rid of all such occurrences -See Note [Binder swap] in "GHC.Core.Opt.OccurAnal". - -BUT it is still VERY IMPORTANT to add a suitable unfolding for a -variable scrutinee, in simplAlt. Here's why - case x of y - (a,b) -> case b of c - I# v -> ...(f y)... -There is no occurrence of 'b' in the (...(f y)...). But y gets -the unfolding (a,b), and *that* mentions b. If f has a RULE - RULE f (p, I# q) = ... -we want that rule to match, so we must extend the in-scope env with a -suitable unfolding for 'y'. It's *essential* for rule matching; but -it's also good for case-elimination -- suppose that 'f' was inlined -and did multi-level case analysis, then we'd solve it in one -simplifier sweep instead of two. - -Exactly the same issue arises in GHC.Core.Opt.SpecConstr; -see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr - -HOWEVER, given - case x of y { Just a -> r1; Nothing -> r2 } -we do not want to add the unfolding x -> y to 'x', which might seem cool, -since 'y' itself has different unfoldings in r1 and r2. Reason: if we -did that, we'd have to zap y's deadness info and that is a very useful -piece of information. - -So instead we add the unfolding x -> Just a, and x -> Nothing in the -respective RHSs. - -Since this transformation is tantamount to a binder swap, the same caveat as in -Note [Suppressing binder-swaps on linear case] in OccurAnal apply. - - -************************************************************************ -* * -\subsection{Known constructor} -* * -************************************************************************ +Unfortunately this is another place where we need a special case for +ticks. The following happens quite regularly: -We are a bit careful with occurrence info. Here's an example + x_local = <expression> + x_exported = tick<x> x_local - (\x* -> case x of (a*, b) -> f a) (h v, e) +Which we want to become: -where the * means "occurs once". This effectively becomes - case (h v, e) of (a*, b) -> f a) -and then - let a* = h v; b = e in f a -and then - f (h v) + x_exported = tick<x> <expression> -All this should happen in one sweep. +As it makes no sense to keep the tick and the expression on separate +bindings. Note however that this might increase the ticks scoping +over the execution of x_local, so we can only do this for floatable +ticks. More often than not, other references will be unfoldings of +x_exported, and therefore carry the tick anyway. -} -knownCon :: SimplEnv - -> OutExpr -- The scrutinee - -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) - -> InId -> [InBndr] -> InExpr -- The alternative - -> SimplCont - -> SimplM (SimplFloats, OutExpr) +type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks -knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont - = do { (floats1, env1) <- bind_args env bs dc_args - ; (floats2, env2) <- bind_case_bndr env1 - ; (floats3, expr') <- simplExprF env2 rhs cont - ; case dc_floats of - [] -> - return (floats1 `addFloats` floats2 `addFloats` floats3, expr') - _ -> - return ( emptyFloats env - -- See Note [FloatBinds from constructor wrappers] - , GHC.Core.Make.wrapFloats dc_floats $ - wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') } +shortOutIndirections :: CoreProgram -> CoreProgram +shortOutIndirections binds + | isEmptyVarEnv ind_env = binds + | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping] + | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff where - zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId - - -- Ugh! - bind_args env' [] _ = return (emptyFloats env', env') - - bind_args env' (b:bs') (Type ty : args) - = assert (isTyVar b ) - bind_args (extendTvSubst env' b ty) bs' args - - bind_args env' (b:bs') (Coercion co : args) - = assert (isCoVar b ) - bind_args (extendCvSubst env' b co) bs' args - - bind_args env' (b:bs') (arg : args) - = assert (isId b) $ - do { let b' = zap_occ b - -- Note that the binder might be "dead", because it doesn't - -- occur in the RHS; and simplNonRecX may therefore discard - -- it via postInlineUnconditionally. - -- Nevertheless we must keep it if the case-binder is alive, - -- because it may be used in the con_app. See Note [knownCon occ info] - ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let-can-float invariant - ; (floats2, env3) <- bind_args env2 bs' args - ; return (floats1 `addFloats` floats2, env3) } - - bind_args _ _ _ = - pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ - text "scrut:" <+> ppr scrut - - -- It's useful to bind bndr to scrut, rather than to a fresh - -- binding x = Con arg1 .. argn - -- because very often the scrut is a variable, so we avoid - -- creating, and then subsequently eliminating, a let-binding - -- BUT, if scrut is a not a variable, we must be careful - -- about duplicating the arg redexes; in that case, make - -- a new con-app from the args - bind_case_bndr env - | isDeadBinder bndr = return (emptyFloats env, env) - | exprIsTrivial scrut = return (emptyFloats env - , extendIdSubst env bndr (DoneEx scrut Nothing)) - -- See Note [Do not duplicate constructor applications] - | otherwise = do { dc_args <- mapM (simplVar env) bs - -- dc_ty_args are already OutTypes, - -- but bs are InBndrs - ; let con_app = Var (dataConWorkId dc) - `mkTyApps` dc_ty_args - `mkApps` dc_args - ; simplNonRecX env bndr con_app } - -------------------- -missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -- This isn't strictly an error, although it is unusual. - -- It's possible that the simplifier might "see" that - -- an inner case has no accessible alternatives before - -- it "sees" that the entire branch of an outer case is - -- inaccessible. So we simply put an error case here instead. -missingAlt env case_bndr _ cont - = warnPprTrace True "missingAlt" (ppr case_bndr) $ - -- See Note [Avoiding space leaks in OutType] - let cont_ty = contResultType cont - in seqType cont_ty `seq` - return (emptyFloats env, mkImpossibleExpr cont_ty) - -{- -************************************************************************ -* * -\subsection{Duplicating continuations} -* * -************************************************************************ - -Consider - let x* = case e of { True -> e1; False -> e2 } - in b -where x* is a strict binding. Then mkDupableCont will be given -the continuation - case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop -and will split it into - dupable: case [] of { True -> $j1; False -> $j2 } ; stop - join floats: $j1 = e1, $j2 = e2 - non_dupable: let x* = [] in b; stop - -Putting this back together would give - let x* = let { $j1 = e1; $j2 = e2 } in - case e of { True -> $j1; False -> $j2 } - in b -(Of course we only do this if 'e' wants to duplicate that continuation.) -Note how important it is that the new join points wrap around the -inner expression, and not around the whole thing. - -In contrast, any let-bindings introduced by mkDupableCont can wrap -around the entire thing. - -Note [Bottom alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have - case (case x of { A -> error .. ; B -> e; C -> error ..) - of alts -then we can just duplicate those alts because the A and C cases -will disappear immediately. This is more direct than creating -join points and inlining them away. See #4930. --} - --------------------- -mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont - -> SimplM ( SimplFloats -- Join points (if any) - , SimplEnv -- Use this for the alts - , SimplCont) -mkDupableCaseCont env alts cont - | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont - ; let env' = bumpCaseDepth $ - env `setInScopeFromF` floats - ; return (floats, env', cont) } - | otherwise = return (emptyFloats env, env, cont) - -altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative -altsWouldDup [] = False -- See Note [Bottom alternatives] -altsWouldDup [_] = False -altsWouldDup (alt:alts) - | is_bot_alt alt = altsWouldDup alts - | otherwise = not (all is_bot_alt alts) - -- otherwise case: first alt is non-bot, so all the rest must be bot + ind_env = makeIndEnv binds + -- These exported Ids are the subjects of the indirection-elimination + exp_ids = map fst $ nonDetEltsUFM ind_env + -- It's OK to use nonDetEltsUFM here because we forget the ordering + -- by immediately converting to a set or check if all the elements + -- satisfy a predicate. + exp_id_set = mkVarSet exp_ids + no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids + binds' = concatMap zap binds + + zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] + zap (Rec pairs) = [Rec (concatMap zapPair pairs)] + + zapPair (bndr, rhs) + | bndr `elemVarSet` exp_id_set + = [] -- Kill the exported-id binding + + | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr + , (exp_id', lcl_id') <- transferIdInfo exp_id bndr + = -- Turn a local-id binding into two bindings + -- exp_id = rhs; lcl_id = exp_id + [ (exp_id', mkTicks ticks rhs), + (lcl_id', Var exp_id') ] + + | otherwise + = [(bndr,rhs)] + +makeIndEnv :: [CoreBind] -> IndEnv +makeIndEnv binds + = foldl' add_bind emptyVarEnv binds where - is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs - -------------------------- -mkDupableCont :: SimplEnv - -> SimplCont - -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with - -- extra let/join-floats and in-scope variables - , SimplCont) -- dup_cont: duplicable continuation -mkDupableCont env cont - = mkDupableContWithDmds env (repeat topDmd) cont - -mkDupableContWithDmds - :: SimplEnv -> [Demand] -- Demands on arguments; always infinite - -> SimplCont -> SimplM ( SimplFloats, SimplCont) - -mkDupableContWithDmds env _ cont - | contIsDupable cont - = return (emptyFloats env, cont) - -mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn - -mkDupableContWithDmds env dmds (CastIt ty cont) - = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, CastIt ty cont') } - --- Duplicating ticks for now, not sure if this is good or not -mkDupableContWithDmds env dmds (TickIt t cont) - = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, TickIt t cont') } - -mkDupableContWithDmds env _ - (StrictBind { sc_bndr = bndr, sc_body = body - , sc_env = se, sc_cont = cont}) --- See Note [Duplicating StrictBind] --- K[ let x = <> in b ] --> join j x = K[ b ] --- j <> - = do { let sb_env = se `setInScopeFromE` env - ; (sb_env1, bndr') <- simplBinder sb_env bndr - ; (floats1, join_inner) <- simplLam sb_env1 body cont - -- No need to use mkDupableCont before simplLam; we - -- use cont once here, and then share the result if necessary - - ; let join_body = wrapFloats floats1 join_inner - res_ty = contResultType cont - - ; mkDupableStrictBind env bndr' join_body res_ty } - -mkDupableContWithDmds env _ - (StrictArg { sc_fun = fun, sc_cont = cont - , sc_fun_ty = fun_ty }) - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - | isNothing (isDataConId_maybe (ai_fun fun)) - , thumbsUpPlanA cont -- See point (3) of Note [Duplicating join points] - = -- Use Plan A of Note [Duplicating StrictArg] - do { let (_ : dmds) = ai_dmds fun - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont - -- Use the demands from the function to add the right - -- demand info on any bindings we make for further args - ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env) - (ai_args fun) - ; return ( foldl' addLetFloats floats1 floats_s - , StrictArg { sc_fun = fun { ai_args = args' } - , sc_cont = cont' - , sc_fun_ty = fun_ty - , sc_dup = OkToDup} ) } - - | otherwise - = -- Use Plan B of Note [Duplicating StrictArg] - -- K[ f a b <> ] --> join j x = K[ f a b x ] - -- j <> - do { let rhs_ty = contResultType cont - (m,arg_ty,_) = splitFunTy fun_ty - ; arg_bndr <- newId (fsLit "arg") m arg_ty - ; let env' = env `addNewInScopeIds` [arg_bndr] - ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont - ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } + add_bind :: IndEnv -> CoreBind -> IndEnv + add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs) + add_bind env (Rec pairs) = foldl' add_pair env pairs + + add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv + add_pair env (exported_id, exported) + | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported + , shortMeOut env exported_id local_id + = extendVarEnv env local_id (exported_id, ticks) + add_pair env _ = env + +shortMeOut :: IndEnv -> Id -> Id -> Bool +shortMeOut ind_env exported_id local_id +-- The if-then-else stuff is just so I can get a pprTrace to see +-- how often I don't get shorting out because of IdInfo stuff + = if isExportedId exported_id && -- Only if this is exported + + isLocalId local_id && -- Only if this one is defined in this + -- module, so that we *can* change its + -- binding to be the exported thing! + + not (isExportedId local_id) && -- Only if this one is not itself exported, + -- since the transformation will nuke it + + not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for + then + if hasShortableIdInfo exported_id + then True -- See Note [Messing up the exported Id's RULES] + else warnPprTrace True "Not shorting out" (ppr exported_id) False + else + False + +hasShortableIdInfo :: Id -> Bool +-- True if there is no user-attached IdInfo on exported_id, +-- so we can safely discard it +-- See Note [Messing up the exported Id's RULES] +hasShortableIdInfo id + = isEmptyRuleInfo (ruleInfo info) + && isDefaultInlinePragma (inlinePragInfo info) + && not (isStableUnfolding (realUnfoldingInfo info)) where - thumbsUpPlanA (StrictArg {}) = False - thumbsUpPlanA (CastIt _ k) = thumbsUpPlanA k - thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k - thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k - thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k - thumbsUpPlanA (Select {}) = True - thumbsUpPlanA (StrictBind {}) = True - thumbsUpPlanA (Stop {}) = True - -mkDupableContWithDmds env dmds - (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) - = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, ApplyToTy { sc_cont = cont' - , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } - -mkDupableContWithDmds env dmds - (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se - , sc_cont = cont, sc_hole_ty = hole_ty }) - = -- e.g. [...hole...] (...arg...) - -- ==> - -- let a = ...arg... - -- in [...hole...] a - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:cont_dmds) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont - ; let env' = env `setInScopeFromF` floats1 - ; (_, se', arg') <- simplArg env' dup se arg - ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' - ; let all_floats = floats1 `addLetFloats` let_floats2 - ; return ( all_floats - , ApplyToVal { sc_arg = arg'' - , sc_env = se' `setInScopeFromF` all_floats - -- Ensure that sc_env includes the free vars of - -- arg'' in its in-scope set, even if makeTrivial - -- has turned arg'' into a fresh variable - -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils - , sc_dup = OkToDup, sc_cont = cont' - , sc_hole_ty = hole_ty }) } - -mkDupableContWithDmds env _ - (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) - = -- e.g. (case [...hole...] of { pi -> ei }) - -- ===> - -- let ji = \xij -> ei - -- in case [...hole...] of { pi -> ji xij } - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { tick (CaseOfCase case_bndr) - ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont - -- NB: We call mkDupableCaseCont here to make cont duplicable - -- (if necessary, depending on the number of alts) - -- And this is important: see Note [Fusing case continuations] - - ; let cont_scaling = contHoleScaling cont - -- See Note [Scaling in case-of-case] - ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr) - ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts) - -- Safe to say that there are no handled-cons for the DEFAULT case - -- NB: simplBinder does not zap deadness occ-info, so - -- a dead case_bndr' will still advertise its deadness - -- This is really important because in - -- case e of b { (# p,q #) -> ... } - -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), - -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. - -- In the new alts we build, we have the new case binder, so it must retain - -- its deadness. - -- NB: we don't use alt_env further; it has the substEnv for - -- the alternatives, and we don't want that - - ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr') - emptyJoinFloats alts' - - ; let all_floats = floats `addJoinFloats` join_floats - -- Note [Duplicated env] - ; return (all_floats - , Select { sc_dup = OkToDup - , sc_bndr = case_bndr' - , sc_alts = alts'' - , sc_env = zapSubstEnv se `setInScopeFromF` all_floats - -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils - , sc_cont = mkBoringStop (contResultType cont) } ) } - -mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType - -> SimplM (SimplFloats, SimplCont) -mkDupableStrictBind env arg_bndr join_rhs res_ty - | exprIsTrivial join_rhs -- See point (2) of Note [Duplicating join points] - = return (emptyFloats env - , StrictBind { sc_bndr = arg_bndr - , sc_body = join_rhs - , sc_env = zapSubstEnv env - -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils - , sc_dup = OkToDup - , sc_cont = mkBoringStop res_ty } ) - | otherwise - = do { join_bndr <- newJoinId [arg_bndr] res_ty - ; let arg_info = ArgInfo { ai_fun = join_bndr - , ai_rules = Nothing, ai_args = [] - , ai_encl = False, ai_dmds = repeat topDmd - , ai_discs = repeat 0 } - ; return ( addJoinFloats (emptyFloats env) $ - unitJoinFloat $ - NonRec join_bndr $ - Lam (setOneShotLambda arg_bndr) join_rhs - , StrictArg { sc_dup = OkToDup - , sc_fun = arg_info - , sc_fun_ty = idType join_bndr - , sc_cont = mkBoringStop res_ty - } ) } - -mkDupableAlt :: Platform -> OutId - -> JoinFloats -> OutAlt - -> SimplM (JoinFloats, OutAlt) -mkDupableAlt _platform case_bndr jfloats (Alt con alt_bndrs alt_rhs_in) - | exprIsTrivial alt_rhs_in -- See point (2) of Note [Duplicating join points] - = return (jfloats, Alt con alt_bndrs alt_rhs_in) - - | otherwise - = do { let rhs_ty' = exprType alt_rhs_in - - bangs - | DataAlt c <- con - = dataConRepStrictness c - | otherwise = [] - - abstracted_binders = abstract_binders alt_bndrs bangs - - abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)] - abstract_binders [] [] - -- Abstract over the case binder too if it's used. - | isDeadBinder case_bndr = [] - | otherwise = [(case_bndr,MarkedStrict)] - abstract_binders (alt_bndr:alt_bndrs) marks - -- Abstract over all type variables just in case - | isTyVar alt_bndr = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks - abstract_binders (alt_bndr:alt_bndrs) (mark:marks) - -- The deadness info on the new Ids is preserved by simplBinders - -- We don't abstract over dead ids here. - | isDeadBinder alt_bndr = abstract_binders alt_bndrs marks - | otherwise = (alt_bndr,mark) : abstract_binders alt_bndrs marks - abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in) - - filtered_binders = map fst abstracted_binders - -- We want to make any binder with an evaldUnfolding strict in the rhs. - -- See Note [Call-by-value for worker args] (which also applies to join points) - (rhs_with_seqs) = mkStrictFieldSeqs abstracted_binders alt_rhs_in - - final_args = varsToCoreExprs filtered_binders - -- Note [Join point abstraction] - - -- We make the lambdas into one-shot-lambdas. The - -- join point is sure to be applied at most once, and doing so - -- prevents the body of the join point being floated out by - -- the full laziness pass - final_bndrs = map one_shot filtered_binders - one_shot v | isId v = setOneShotLambda v - | otherwise = v - - -- No lambda binder has an unfolding, but (currently) case binders can, - -- so we must zap them here. - join_rhs = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs - - ; join_bndr <- newJoinId filtered_binders rhs_ty' - - ; let join_call = mkApps (Var join_bndr) final_args - alt' = Alt con alt_bndrs join_call - - ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) - , alt') } - -- See Note [Duplicated env] - -{- -Note [Fusing case continuations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important to fuse two successive case continuations when the -first has one alternative. That's why we call prepareCaseCont here. -Consider this, which arises from thunk splitting (see Note [Thunk -splitting] in GHC.Core.Opt.WorkWrap): - - let - x* = case (case v of {pn -> rn}) of - I# a -> I# a - in body - -The simplifier will find - (Var v) with continuation - Select (pn -> rn) ( - Select [I# a -> I# a] ( - StrictBind body Stop - -So we'll call mkDupableCont on - Select [I# a -> I# a] (StrictBind body Stop) -There is just one alternative in the first Select, so we want to -simplify the rhs (I# a) with continuation (StrictBind body Stop) -Supposing that body is big, we end up with - let $j a = <let x = I# a in body> - in case v of { pn -> case rn of - I# a -> $j a } -This is just what we want because the rn produces a box that -the case rn cancels with. - -See #4957 a fuller example. - -Note [Duplicating join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -IN #19996 we discovered that we want to be really careful about -inlining join points. Consider - case (join $j x = K f x ) - (in case v of ) - ( p1 -> $j x1 ) of - ( p2 -> $j x2 ) - ( p3 -> $j x3 ) - K g y -> blah[g,y] - -Here the join-point RHS is very small, just a constructor -application (K x y). So we might inline it to get - case (case v of ) - ( p1 -> K f x1 ) of - ( p2 -> K f x2 ) - ( p3 -> K f x3 ) - K g y -> blah[g,y] + info = idInfo id -But now we have to make `blah` into a join point, /abstracted/ -over `g` and `y`. In contrast, if we /don't/ inline $j we -don't need a join point for `blah` and we'll get - join $j x = let g=f, y=x in blah[g,y] - in case v of - p1 -> $j x1 - p2 -> $j x2 - p3 -> $j x3 - -This can make a /massive/ difference, because `blah` can see -what `f` is, instead of lambda-abstracting over it. - -To achieve this: - -1. Do not postInlineUnconditionally a join point, until the Final - phase. (The Final phase is still quite early, so we might consider - delaying still more.) - -2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for - all alternatives, except for exprIsTrival RHSs. Previously we used - exprIsDupable. This generates a lot more join points, but makes - them much more case-of-case friendly. - - It is definitely worth checking for exprIsTrivial, otherwise we get - an extra Simplifier iteration, because it is inlined in the next - round. - -3. By the same token we want to use Plan B in - Note [Duplicating StrictArg] when the RHS of the new join point - is a data constructor application. That same Note explains why we - want Plan A when the RHS of the new join point would be a - non-data-constructor application - -4. You might worry that $j will be inlined by the call-site inliner, - but it won't because the call-site context for a join is usually - extremely boring (the arguments come from the pattern match). - And if not, then perhaps inlining it would be a good idea. - - You might also wonder if we get UnfWhen, because the RHS of the - join point is no bigger than the call. But in the cases we care - about it will be a little bigger, because of that free `f` in - $j x = K f x - So for now we don't do anything special in callSiteInline - -There is a bit of tension between (2) and (3). Do we want to retain -the join point only when the RHS is -* a constructor application? or -* just non-trivial? -Currently, a bit ad-hoc, but we definitely want to retain the join -point for data constructors in mkDupalbleALt (point 2); that is the -whole point of #19996 described above. - -Historical Note [Case binders and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: this entire Note is now irrelevant. In Jun 21 we stopped -adding unfoldings to lambda binders (#17530). It was always a -hack and bit us in multiple small and not-so-small ways - -Consider this - case (case .. ) of c { - I# c# -> ....c.... - -If we make a join point with c but not c# we get - $j = \c -> ....c.... - -But if later inlining scrutinises the c, thus - - $j = \c -> ... case c of { I# y -> ... } ... - -we won't see that 'c' has already been scrutinised. This actually -happens in the 'tabulate' function in wave4main, and makes a significant -difference to allocation. - -An alternative plan is this: - - $j = \c# -> let c = I# c# in ...c.... - -but that is bad if 'c' is *not* later scrutinised. - -So instead we do both: we pass 'c' and 'c#' , and record in c's inlining -(a stable unfolding) that it's really I# c#, thus - - $j = \c# -> \c[=I# c#] -> ...c.... - -Absence analysis may later discard 'c'. - -NB: take great care when doing strictness analysis; - see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal. - -Also note that we can still end up passing stuff that isn't used. Before -strictness analysis we have - let $j x y c{=(x,y)} = (h c, ...) - in ... -After strictness analysis we see that h is strict, we end up with - let $j x y c{=(x,y)} = ($wh x y, ...) -and c is unused. - -Note [Duplicated env] -~~~~~~~~~~~~~~~~~~~~~ -Some of the alternatives are simplified, but have not been turned into a join point -So they *must* have a zapped subst-env. So we can't use completeNonRecX to -bind the join point, because it might to do PostInlineUnconditionally, and -we'd lose that when zapping the subst-env. We could have a per-alt subst-env, -but zapping it (as we do in mkDupableCont, the Select case) is safe, and -at worst delays the join-point inlining. - -Note [Funky mkLamTypes] -~~~~~~~~~~~~~~~~~~~~~~ -Notice the funky mkLamTypes. If the constructor has existentials -it's possible that the join point will be abstracted over -type variables as well as term variables. - Example: Suppose we have - data T = forall t. C [t] - Then faced with - case (case e of ...) of - C t xs::[t] -> rhs - We get the join point - let j :: forall t. [t] -> ... - j = /\t \xs::[t] -> rhs - in - case (case e of ...) of - C t xs::[t] -> j t xs - -Note [Duplicating StrictArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Dealing with making a StrictArg continuation duplicable has turned out -to be one of the trickiest corners of the simplifier, giving rise -to several cases in which the simplier expanded the program's size -*exponentially*. They include - #13253 exponential inlining - #10421 ditto - #18140 strict constructors - #18282 another nested-function call case - -Suppose we have a call - f e1 (case x of { True -> r1; False -> r2 }) e3 -and f is strict in its second argument. Then we end up in -mkDupableCont with a StrictArg continuation for (f e1 <> e3). -There are two ways to make it duplicable. - -* Plan A: move the entire call inwards, being careful not - to duplicate e1 or e3, thus: - let a1 = e1 - a3 = e3 - in case x of { True -> f a1 r1 a3 - ; False -> f a1 r2 a3 } - -* Plan B: make a join point: - join $j x = f e1 x e3 - in case x of { True -> jump $j r1 - ; False -> jump $j r2 } - - Notice that Plan B is very like the way we handle strict bindings; - see Note [Duplicating StrictBind]. And Plan B is exactly what we'd - get if we turned use a case expression to evaluate the strict arg: - - case (case x of { True -> r1; False -> r2 }) of - r -> f e1 r e3 - - So, looking at Note [Duplicating join points], we also want Plan B - when `f` is a data constructor. - -Plan A is often good. Here's an example from #3116 - go (n+1) (case l of - 1 -> bs' - _ -> Chunk p fpc (o+1) (l-1) bs') - -If we pushed the entire call for 'go' inside the case, we get -call-pattern specialisation for 'go', which is *crucial* for -this particular program. - -Here is another example. - && E (case x of { T -> F; F -> T }) - -Pushing the call inward (being careful not to duplicate E) - let a = E - in case x of { T -> && a F; F -> && a T } - -and now the (&& a F) etc can optimise. Moreover there might -be a RULE for the function that can fire when it "sees" the -particular case alternative. - -But Plan A can have terrible, terrible behaviour. Here is a classic -case: - f (f (f (f (f True)))) - -Suppose f is strict, and has a body that is small enough to inline. -The innermost call inlines (seeing the True) to give - f (f (f (f (case v of { True -> e1; False -> e2 })))) - -Now, suppose we naively push the entire continuation into both -case branches (it doesn't look large, just f.f.f.f). We get - case v of - True -> f (f (f (f e1))) - False -> f (f (f (f e2))) - -And now the process repeats, so we end up with an exponentially large -number of copies of f. No good! - -CONCLUSION: we want Plan A in general, but do Plan B is there a -danger of this nested call behaviour. The function that decides -this is called thumbsUpPlanA. - -Note [Keeping demand info in StrictArg Plan A] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Following on from Note [Duplicating StrictArg], another common code -pattern that can go bad is this: - f (case x1 of { T -> F; F -> T }) - (case x2 of { T -> F; F -> T }) - ...etc... -when f is strict in all its arguments. (It might, for example, be a -strict data constructor whose wrapper has not yet been inlined.) - -We use Plan A (because there is no nesting) giving - let a2 = case x2 of ... - a3 = case x3 of ... - in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... } - -Now we must be careful! a2 and a3 are small, and the OneOcc code in -postInlineUnconditionally may inline them both at both sites; see Note -Note [Inline small things to avoid creating a thunk] in -Simplify.Utils. But if we do inline them, the entire process will -repeat -- back to exponential behaviour. - -So we are careful to keep the demand-info on a2 and a3. Then they'll -be /strict/ let-bindings, which will be dealt with by StrictBind. -That's why contIsDupableWithDmds is careful to propagage demand -info to the auxiliary bindings it creates. See the Demand argument -to makeTrivial. - -Note [Duplicating StrictBind] +{- Note [Transferring IdInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We make a StrictBind duplicable in a very similar way to -that for case expressions. After all, - let x* = e in b is similar to case e of x -> b - -So we potentially make a join-point for the body, thus: - let x = <> in b ==> join j x = b - in j <> - -Just like StrictArg in fact -- and indeed they share code. +If we have + lcl_id = e; exp_id = lcl_id -Note [Join point abstraction] Historical note -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: This note is now historical, describing how (in the past) we used -to add a void argument to nullary join points. But now that "join -point" is not a fuzzy concept but a formal syntactic construct (as -distinguished by the JoinId constructor of IdDetails), each of these -concerns is handled separately, with no need for a vestigial extra -argument. +and lcl_id has useful IdInfo, we don't want to discard it by going + gbl_id = e; lcl_id = gbl_id -Join points always have at least one value argument, -for several reasons +Instead, transfer IdInfo from lcl_id to exp_id, specifically +* (Stable) unfolding +* Strictness +* Rules +* Inline pragma -* If we try to lift a primitive-typed something out - for let-binding-purposes, we will *caseify* it (!), - with potentially-disastrous strictness results. So - instead we turn it into a function: \v -> e - where v::Void#. The value passed to this function is void, - which generates (almost) no code. +Overwriting, rather than merging, seems to work ok. -* CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now - we make the join point into a function whenever used_bndrs' - is empty. This makes the join-point more CPR friendly. - Consider: let j = if .. then I# 3 else I# 4 - in case .. of { A -> j; B -> j; C -> ... } +For the lcl_id we - Now CPR doesn't w/w j because it's a thunk, so - that means that the enclosing function can't w/w either, - which is a lose. Here's the example that happened in practice: - kgmod :: Int -> Int -> Int - kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 - then 78 - else 5 +* Zap the InlinePragma. It might originally have had a NOINLINE, which + we have now transferred; and we really want the lcl_id to inline now + that its RHS is trivial! -* Let-no-escape. We want a join point to turn into a let-no-escape - so that it is implemented as a jump, and one of the conditions - for LNE is that it's not updatable. In CoreToStg, see - Note [What is a non-escaping let] - -* Floating. Since a join point will be entered once, no sharing is - gained by floating out, but something might be lost by doing - so because it might be allocated. - -I have seen a case alternative like this: - True -> \v -> ... -It's a bit silly to add the realWorld dummy arg in this case, making - $j = \s v -> ... - True -> $j s -(the \v alone is enough to make CPR happy) but I think it's rare - -There's a slight infelicity here: we pass the overall -case_bndr to all the join points if it's used in *any* RHS, -because we don't know its usage in each RHS separately - - - -************************************************************************ -* * - Unfoldings -* * -************************************************************************ --} - -simplLetUnfolding :: SimplEnv - -> BindContext - -> InId - -> OutExpr -> OutType -> ArityType - -> Unfolding -> SimplM Unfolding -simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf - | isStableUnfolding unf - = simplStableUnfolding env bind_cxt id rhs_ty arity unf - | isExitJoinId id - = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify - | otherwise - = -- Otherwise, we end up retaining all the SimpleEnv - let !opts = seUnfoldingOpts env - in mkLetUnfolding opts (bindContextLevel bind_cxt) InlineRhs id new_rhs - -------------------- -mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource - -> InId -> OutExpr -> SimplM Unfolding -mkLetUnfolding !uf_opts top_lvl src id new_rhs - = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs) - -- We make an unfolding *even for loop-breakers*. - -- Reason: (a) It might be useful to know that they are WHNF - -- (b) In GHC.Iface.Tidy we currently assume that, if we want to - -- expose the unfolding then indeed we *have* an unfolding - -- to expose. (We could instead use the RHS, but currently - -- we don't.) The simple thing is always to have one. - where - -- Might as well force this, profiles indicate up to 0.5MB of thunks - -- just from this site. - !is_top_lvl = isTopLevel top_lvl - -- See Note [Force bottoming field] - !is_bottoming = isDeadEndId id - -------------------- -simplStableUnfolding :: SimplEnv -> BindContext - -> InId - -> OutType - -> ArityType -- Used to eta expand, but only for non-join-points - -> Unfolding - ->SimplM Unfolding --- Note [Setting the new unfolding] -simplStableUnfolding env bind_cxt id rhs_ty id_arity unf - = case unf of - NoUnfolding -> return unf - BootUnfolding -> return unf - OtherCon {} -> return unf - - DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } - -> do { (env', bndrs') <- simplBinders unf_env bndrs - ; args' <- mapM (simplExpr env') args - ; return (mkDFunUnfolding bndrs' con args') } - - CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } - | isStableSource src - -> do { expr' <- case bind_cxt of - BC_Join cont -> -- Binder is a join point - -- See Note [Rules and unfolding for join points] - simplJoinRhs unf_env id expr cont - BC_Let _ is_rec -> -- Binder is not a join point - do { let cont = mkRhsStop rhs_ty is_rec topDmd - -- mkRhsStop: switch off eta-expansion at the top level - ; expr' <- simplExprC unf_env expr cont - ; return (eta_expand expr') } - ; case guide of - UnfWhen { ug_arity = arity - , ug_unsat_ok = sat_ok - , ug_boring_ok = boring_ok - } - -- Happens for INLINE things - -- Really important to force new_boring_ok as otherwise - -- `ug_boring_ok` is a thunk chain of - -- inlineBoringExprOk expr0 - -- || inlineBoringExprOk expr1 || ... - -- See #20134 - -> let !new_boring_ok = boring_ok || inlineBoringOk expr' - guide' = - UnfWhen { ug_arity = arity - , ug_unsat_ok = sat_ok - , ug_boring_ok = new_boring_ok - - } - -- Refresh the boring-ok flag, in case expr' - -- has got small. This happens, notably in the inlinings - -- for dfuns for single-method classes; see - -- Note [Single-method classes] in GHC.Tc.TyCl.Instance. - -- A test case is #4138 - -- But retain a previous boring_ok of True; e.g. see - -- the way it is set in calcUnfoldingGuidanceWithArity - in return (mkCoreUnfolding src is_top_lvl expr' guide') - -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold - - _other -- Happens for INLINABLE things - -> mkLetUnfolding uf_opts top_lvl src id expr' } - -- If the guidance is UnfIfGoodArgs, this is an INLINABLE - -- unfolding, and we need to make sure the guidance is kept up - -- to date with respect to any changes in the unfolding. - - | otherwise -> return noUnfolding -- Discard unstable unfoldings - where - uf_opts = seUnfoldingOpts env - -- Forcing this can save about 0.5MB of max residency and the result - -- is small and easy to compute so might as well force it. - top_lvl = bindContextLevel bind_cxt - !is_top_lvl = isTopLevel top_lvl - act = idInlineActivation id - unf_env = updMode (updModeForStableUnfoldings act) env - -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils - - -- See Note [Eta-expand stable unfoldings] - -- Use the arity from the main Id (in id_arity), rather than computing it from rhs - eta_expand expr | sm_eta_expand (getMode env) - , exprArity expr < arityTypeArity id_arity - , wantEtaExpansion expr - = etaExpandAT (getInScope env) id_arity expr - | otherwise - = expr - -{- Note [Eta-expand stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For INLINE/INLINABLE things (which get stable unfoldings) there's a danger -of getting - f :: Int -> Int -> Int -> Blah - [ Arity = 3 -- Good arity - , Unf=Stable (\xy. blah) -- Less good arity, only 2 - f = \pqr. e - -This can happen because f's RHS is optimised more vigorously than -its stable unfolding. Now suppose we have a call - g = f x -Because f has arity=3, g will have arity=2. But if we inline f (using -its stable unfolding) g's arity will reduce to 1, because <blah> -hasn't been optimised yet. This happened in the 'parsec' library, -for Text.Pasec.Char.string. - -Generally, if we know that 'f' has arity N, it seems sensible to -eta-expand the stable unfolding to arity N too. Simple and consistent. - -Wrinkles - -* See Historical-note [Eta-expansion in stable unfoldings] in - GHC.Core.Opt.Simplify.Utils - -* Don't eta-expand a trivial expr, else each pass will eta-reduce it, - and then eta-expand again. See Note [Which RHSs do we eta-expand?] - in GHC.Core.Opt.Simplify.Utils. - -* Don't eta-expand join points; see Note [Do not eta-expand join points] - in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point - case (bind_cxt = BC_Join _) doesn't use eta_expand. - -Note [Force bottoming field] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to force bottoming, or the new unfolding holds -on to the old unfolding (which is part of the id). - -Note [Setting the new unfolding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* If there's an INLINE pragma, we simplify the RHS gently. Maybe we - should do nothing at all, but simplifying gently might get rid of - more crap. - -* If not, we make an unfolding from the new RHS. But *only* for - non-loop-breakers. Making loop breakers not have an unfolding at all - means that we can avoid tests in exprIsConApp, for example. This is - important: if exprIsConApp says 'yes' for a recursive thing, then we - can get into an infinite loop - -If there's a stable unfolding on a loop breaker (which happens for -INLINABLE), we hang on to the inlining. It's pretty dodgy, but the -user did say 'INLINE'. May need to revisit this choice. - -************************************************************************ -* * - Rules -* * -************************************************************************ - -Note [Rules in a letrec] -~~~~~~~~~~~~~~~~~~~~~~~~ -After creating fresh binders for the binders of a letrec, we -substitute the RULES and add them back onto the binders; this is done -*before* processing any of the RHSs. This is important. Manuel found -cases where he really, really wanted a RULE for a recursive function -to apply in that function's own right-hand side. - -See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal" +* Zap any Stable unfolding. agian, we want lcl_id = gbl_id to inline, + replacing lcl_id by gbl_id. That won't happen if lcl_id has its original + great big Stable unfolding -} -addBndrRules :: SimplEnv -> InBndr -> OutBndr - -> BindContext - -> SimplM (SimplEnv, OutBndr) --- Rules are added back into the bin -addBndrRules env in_id out_id bind_cxt - | null old_rules - = return (env, out_id) - | otherwise - = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt - ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules - ; return (modifyInScope env final_id, final_id) } - where - old_rules = ruleInfoRules (idSpecialisation in_id) - -simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule] --- Simplify local rules for imported Ids -simplImpRules env rules - = simplRules env Nothing rules (BC_Let TopLevel NonRecursive) - -simplRules :: SimplEnv -> Maybe OutId -> [CoreRule] - -> BindContext -> SimplM [CoreRule] -simplRules env mb_new_id rules bind_cxt - = mapM simpl_rule rules +transferIdInfo :: Id -> Id -> (Id, Id) +-- See Note [Transferring IdInfo] +transferIdInfo exported_id local_id + = ( modifyIdInfo transfer exported_id + , modifyIdInfo zap_info local_id ) where - simpl_rule rule@(BuiltinRule {}) - = return rule - - simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args - , ru_fn = fn_name, ru_rhs = rhs - , ru_act = act }) - = do { (env', bndrs') <- simplBinders env bndrs - ; let rhs_ty = substTy env' (exprType rhs) - rhs_cont = case bind_cxt of -- See Note [Rules and unfolding for join points] - BC_Let {} -> mkBoringStop rhs_ty - BC_Join cont -> assertPpr join_ok bad_join_msg cont - lhs_env = updMode updModeForRules env' - rhs_env = updMode (updModeForStableUnfoldings act) env' - -- See Note [Simplifying the RHS of a RULE] - fn_name' = case mb_new_id of - Just id -> idName id - Nothing -> fn_name - - -- join_ok is an assertion check that the join-arity of the - -- binder matches that of the rule, so that pushing the - -- continuation into the RHS makes sense - join_ok = case mb_new_id of - Just id | Just join_arity <- isJoinId_maybe id - -> length args == join_arity - _ -> False - bad_join_msg = vcat [ ppr mb_new_id, ppr rule - , ppr (fmap isJoinId_maybe mb_new_id) ] - - ; args' <- mapM (simplExpr lhs_env) args - ; rhs' <- simplExprC rhs_env rhs rhs_cont - ; return (rule { ru_bndrs = bndrs' - , ru_fn = fn_name' - , ru_args = args' - , ru_rhs = rhs' }) } - -{- Note [Simplifying the RHS of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can simplify the RHS of a RULE much as we do the RHS of a stable -unfolding. We used to use the much more conservative updModeForRules -for the RHS as well as the LHS, but that seems more conservative -than necesary. Allowing some inlining might, for example, eliminate -a binding. --} + local_info = idInfo local_id + transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info + `setCprSigInfo` cprSigInfo local_info + `setUnfoldingInfo` realUnfoldingInfo local_info + `setInlinePragInfo` inlinePragInfo local_info + `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info + new_info = setRuleInfoHead (idName exported_id) + (ruleInfo local_info) + -- Remember to set the function-name field of the + -- rules as we transfer them from one function to another + + zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma + `setUnfoldingInfo` noUnfolding diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 47927d5d7f..b8cf447634 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -8,10 +8,15 @@ module GHC.Core.Opt.Simplify.Env ( -- * The simplifier mode - setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, seLogger, + SimplMode(..), updMode, + smPedanticBottoms, smPlatform, -- * Environments SimplEnv(..), pprSimplEnv, -- Temp not abstract + seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle, + seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames, + seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline, + seRuleOpts, seRules, seUnfoldingOpts, mkSimplEnv, extendIdSubst, extendTvSubst, extendCvSubst, zapSubstEnv, setSubstEnv, bumpCaseDepth, @@ -46,8 +51,11 @@ module GHC.Core.Opt.Simplify.Env ( import GHC.Prelude +import GHC.Core.Coercion.Opt ( OptCoercionOpts ) +import GHC.Core.FamInstEnv ( FamInstEnv ) +import GHC.Core.Opt.Arity ( ArityOpts(..) ) import GHC.Core.Opt.Simplify.Monad -import GHC.Core.Opt.Monad ( SimplMode(..), FloatEnable (..) ) +import GHC.Core.Rules.Config ( RuleOpts(..) ) import GHC.Core import GHC.Core.Utils import GHC.Core.Multiplicity ( scaleScaled ) @@ -59,23 +67,22 @@ import GHC.Data.OrdList import GHC.Data.Graph.UnVar import GHC.Types.Id as Id import GHC.Core.Make ( mkWildValBinder, mkCoreLet ) -import GHC.Driver.Session ( DynFlags ) import GHC.Builtin.Types import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import qualified GHC.Core.Type as Type import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst ) import qualified GHC.Core.Coercion as Coercion import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) +import GHC.Platform ( Platform ) import GHC.Types.Basic import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc -import GHC.Utils.Logger import GHC.Types.Unique.FM ( pprUniqFM ) -import Data.List (mapAccumL) +import Data.List ( intersperse, mapAccumL ) {- ************************************************************************ @@ -85,13 +92,75 @@ import Data.List (mapAccumL) ************************************************************************ -} +{- +Note [The environments of the Simplify pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions of the Simplify pass draw their contextual data from two +environments: `SimplEnv`, which is passed to the functions as an argument, and +`SimplTopEnv`, which is part of the `SimplM` monad. For both environments exist +corresponding configuration records `SimplMode` and `TopEnvConfig` respectively. +A configuration record denotes a unary datatype bundeling the various options +and switches we provide to control the behaviour of the respective part of the +Simplify pass. The value is provided by the driver using the functions found in +the GHC.Driver.Config.Core.Opt.Simplify module. + +These configuration records are part in the environment to avoid needless +copying of their values. This raises the question which data value goes in which +of the four datatypes. For each value needed by the pass we ask the following +two questions: + + * Does the value only make sense in a monadic environment? + + * Is it part of the configuration of the pass and provided by the user or is it + it an internal value? + +Examples of values that make only sense in conjunction with `SimplM` are the +logger and the values related to counting. As it does not make sense to use them +in a pure function (the logger needs IO and counting needs access to the +accumulated counts in the monad) we want these to live in `SimplTopEnv`. +Other values, like the switches controlling the behaviour of the pass (e.g. +whether to do case merging or not) are perfectly usable in a non-monadic setting. +Indeed many of those are used in guard expressions and it would be cumbersome to +query them from the monadic environment and feed them to the pure functions as +an argument. Hence we conveniently store them in the `SpecEnv` environment which +can be passed to pure functions as a whole. + +Now that we know in which of the two environments a particular value lives we +turn to the second question to determine if the value is part of the +configuration record embedded in the environment or if it is stored in an own +field in the environment type. Some values like the tick factor must be provided +from outside as we can neither derive it from other values provided to us nor +does a constant value make sense. Other values like the maximal number of ticks +are computed on environment initialization and we wish not to expose the field +to the "user" or the pass -- it is an internal value. Therefore the distinction +here is between "freely set by the caller" and "internally managed by the pass". + +Note that it doesn't matter for the decision procedure wheter a value is altered +throughout an iteration of the Simplify pass: The fields sm_phase, sm_inline, +sm_rules, sm_cast_swizzle and sm_eta_expand are updated locally (See the +definitions of `updModeForStableUnfoldings` and `updModeForRules` in +GHC.Core.Opt.Simplify.Utils) but they are still part of `SimplMode` as the +caller of the Simplify pass needs to provide the initial values for those fields. + +The decision which value goes into which datatype can be summarized by the +following table: + | Usable in a | + | pure setting | monadic setting | + |----------------------------|--------------|-----------------| + | Set by user | SimplMode | TopEnvConfig | + | Computed on initialization | SimplEnv | SimplTopEnv | + +-} + data SimplEnv = SimplEnv { ----------- Static part of the environment ----------- -- Static in the sense of lexically scoped, -- wrt the original expression + -- See Note [The environments of the Simplify pass] seMode :: !SimplMode + , seFamEnvs :: !(FamInstEnv, FamInstEnv) -- The current substitution , seTvSubst :: TvSubstEnv -- InTyVar |--> OutType @@ -113,6 +182,137 @@ data SimplEnv , seCaseDepth :: !Int -- Depth of multi-branch case alternatives } +seArityOpts :: SimplEnv -> ArityOpts +seArityOpts env = sm_arity_opts (seMode env) + +seCaseCase :: SimplEnv -> Bool +seCaseCase env = sm_case_case (seMode env) + +seCaseFolding :: SimplEnv -> Bool +seCaseFolding env = sm_case_folding (seMode env) + +seCaseMerge :: SimplEnv -> Bool +seCaseMerge env = sm_case_merge (seMode env) + +seCastSwizzle :: SimplEnv -> Bool +seCastSwizzle env = sm_cast_swizzle (seMode env) + +seDoEtaReduction :: SimplEnv -> Bool +seDoEtaReduction env = sm_do_eta_reduction (seMode env) + +seEtaExpand :: SimplEnv -> Bool +seEtaExpand env = sm_eta_expand (seMode env) + +seFloatEnable :: SimplEnv -> FloatEnable +seFloatEnable env = sm_float_enable (seMode env) + +seInline :: SimplEnv -> Bool +seInline env = sm_inline (seMode env) + +seNames :: SimplEnv -> [String] +seNames env = sm_names (seMode env) + +seOptCoercionOpts :: SimplEnv -> OptCoercionOpts +seOptCoercionOpts env = sm_co_opt_opts (seMode env) + +sePedanticBottoms :: SimplEnv -> Bool +sePedanticBottoms env = smPedanticBottoms (seMode env) + +sePhase :: SimplEnv -> CompilerPhase +sePhase env = sm_phase (seMode env) + +sePlatform :: SimplEnv -> Platform +sePlatform env = smPlatform (seMode env) + +sePreInline :: SimplEnv -> Bool +sePreInline env = sm_pre_inline (seMode env) + +seRuleOpts :: SimplEnv -> RuleOpts +seRuleOpts env = sm_rule_opts (seMode env) + +seRules :: SimplEnv -> Bool +seRules env = sm_rules (seMode env) + +seUnfoldingOpts :: SimplEnv -> UnfoldingOpts +seUnfoldingOpts env = sm_uf_opts (seMode env) + +-- See Note [The environments of the Simplify pass] +data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad + { sm_phase :: !CompilerPhase + , sm_names :: ![String] -- ^ Name(s) of the phase + , sm_rules :: !Bool -- ^ Whether RULES are enabled + , sm_inline :: !Bool -- ^ Whether inlining is enabled + , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled + , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? + , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options + , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled + , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled + , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out + , sm_do_eta_reduction :: !Bool + , sm_arity_opts :: !ArityOpts + , sm_rule_opts :: !RuleOpts + , sm_case_folding :: !Bool + , sm_case_merge :: !Bool + , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options + } + +instance Outputable SimplMode where + ppr (SimplMode { sm_phase = p , sm_names = ss + , sm_rules = r, sm_inline = i + , sm_cast_swizzle = cs + , sm_eta_expand = eta, sm_case_case = cc }) + = text "SimplMode" <+> braces ( + sep [ text "Phase =" <+> ppr p <+> + brackets (text (concat $ intersperse "," ss)) <> comma + , pp_flag i (text "inline") <> comma + , pp_flag r (text "rules") <> comma + , pp_flag eta (text "eta-expand") <> comma + , pp_flag cs (text "cast-swizzle") <> comma + , pp_flag cc (text "case-of-case") ]) + where + pp_flag f s = ppUnless f (text "no") <+> s + +smPedanticBottoms :: SimplMode -> Bool +smPedanticBottoms opts = ao_ped_bot (sm_arity_opts opts) + +smPlatform :: SimplMode -> Platform +smPlatform opts = roPlatform (sm_rule_opts opts) + +data FloatEnable -- Controls local let-floating + = FloatDisabled -- Do no local let-floating + | FloatNestedOnly -- Local let-floating for nested (NotTopLevel) bindings only + | FloatEnabled -- Do local let-floating on all bindings + +{- +Note [Local floating] +~~~~~~~~~~~~~~~~~~~~~ +The Simplifier can perform local let-floating: it floats let-bindings +out of the RHS of let-bindings. See + Let-floating: moving bindings to give faster programs (ICFP'96) + https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/ + +Here's an example + x = let y = v+1 in (y,true) + +The RHS of x is a thunk. Much better to float that y-binding out to give + y = v+1 + x = (y,true) + +Not only have we avoided building a thunk, but any (case x of (p,q) -> ...) in +the scope of the x-binding can now be simplified. + +This local let-floating is done in GHC.Core.Opt.Simplify.prepareBinding, +controlled by the predicate GHC.Core.Opt.Simplify.Env.doFloatFromRhs. + +The `FloatEnable` data type controls where local let-floating takes place; +it allows you to specify that it should be done only for nested bindings; +or for top-level bindings as well; or not at all. + +Note that all of this is quite separate from the global FloatOut pass; +see GHC.Core.Opt.FloatOut. + +-} + data SimplFloats = SimplFloats { -- Ordinary let bindings @@ -285,9 +485,10 @@ need to know at the occurrence site that the variable is a join point so that we know to drop the context. Thus we remember which join points we're substituting. -} -mkSimplEnv :: SimplMode -> SimplEnv -mkSimplEnv mode +mkSimplEnv :: SimplMode -> (FamInstEnv, FamInstEnv) -> SimplEnv +mkSimplEnv mode fam_envs = SimplEnv { seMode = mode + , seFamEnvs = fam_envs , seInScope = init_in_scope , seTvSubst = emptyVarEnv , seCvSubst = emptyVarEnv @@ -320,23 +521,6 @@ wild-ids before doing much else. It's a very dark corner of GHC. Maybe it should be cleaned up. -} -getMode :: SimplEnv -> SimplMode -getMode env = seMode env - -seDynFlags :: SimplEnv -> DynFlags -seDynFlags env = sm_dflags (seMode env) - -seLogger :: SimplEnv -> Logger -seLogger env = sm_logger (seMode env) - - -seUnfoldingOpts :: SimplEnv -> UnfoldingOpts -seUnfoldingOpts env = sm_uf_opts (seMode env) - - -setMode :: SimplMode -> SimplEnv -> SimplEnv -setMode mode env = env { seMode = mode } - updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv updMode upd env = -- Avoid keeping env alive in case inlining fails. diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs new file mode 100644 index 0000000000..ab03872365 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -0,0 +1,4325 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[Simplify]{The main module of the simplifier} +-} + + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} +module GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Driver.Flags + +import GHC.Core +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Simplify.Utils +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs ) +import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) +import qualified GHC.Core.Make +import GHC.Core.Coercion hiding ( substCo, substCoVar ) +import GHC.Core.Reduction +import GHC.Core.Coercion.Opt ( optCoercion ) +import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) +import GHC.Core.DataCon + ( DataCon, dataConWorkId, dataConRepStrictness + , dataConRepArgTys, isUnboxedTupleDataCon + , StrictnessMark (..) ) +import GHC.Core.Opt.Stats ( Tick(..) ) +import GHC.Core.Ppr ( pprCoreExpr ) +import GHC.Core.Unfold +import GHC.Core.Unfold.Make +import GHC.Core.Utils +import GHC.Core.Opt.Arity ( ArityType, exprArity, getBotArity + , pushCoTyArg, pushCoValArg + , typeArity, arityTypeArity, etaExpandAT ) +import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) +import GHC.Core.FVs ( mkRuleInfo ) +import GHC.Core.Rules ( lookupRule, getRules ) +import GHC.Core.Multiplicity + +import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326 +import GHC.Types.SourceText +import GHC.Types.Id +import GHC.Types.Id.Make ( seqId ) +import GHC.Types.Id.Info +import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) +import GHC.Types.Demand +import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Unique ( hasKey ) +import GHC.Types.Basic +import GHC.Types.Tickish +import GHC.Types.Var ( isTyCoVar ) +import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) +import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) +import GHC.Builtin.Names( runRWKey ) + +import GHC.Data.Maybe ( isNothing, orElse ) +import GHC.Data.FastString +import GHC.Unit.Module ( moduleName ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Trace +import GHC.Utils.Monad ( mapAccumLM, liftIO ) +import GHC.Utils.Logger +import GHC.Utils.Misc + +import Control.Monad + +{- +The guts of the simplifier is in this module, but the driver loop for +the simplifier is in GHC.Core.Opt.Pipeline + +Note [The big picture] +~~~~~~~~~~~~~~~~~~~~~~ +The general shape of the simplifier is this: + + simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) + simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) + + * SimplEnv contains + - Simplifier mode + - Ambient substitution + - InScopeSet + + * SimplFloats contains + - Let-floats (which includes ok-for-spec case-floats) + - Join floats + - InScopeSet (including all the floats) + + * Expressions + simplExpr :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + The result of simplifying an /expression/ is (floats, expr) + - A bunch of floats (let bindings, join bindings) + - A simplified expression. + The overall result is effectively (let floats in expr) + + * Bindings + simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) + The result of simplifying a binding is + - A bunch of floats, the last of which is the simplified binding + There may be auxiliary bindings too; see prepareRhs + - An environment suitable for simplifying the scope of the binding + + The floats may also be empty, if the binding is inlined unconditionally; + in that case the returned SimplEnv will have an augmented substitution. + + The returned floats and env both have an in-scope set, and they are + guaranteed to be the same. + + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +The simplifier used to guarantee that the output had no shadowing, but +it does not do so any more. (Actually, it never did!) The reason is +documented with simplifyArgs. + + +Eta expansion +~~~~~~~~~~~~~~ +For eta expansion, we want to catch things like + + case e of (a,b) -> \x -> case a of (p,q) -> \y -> r + +If the \x was on the RHS of a let, we'd eta expand to bring the two +lambdas together. And in general that's a good thing to do. Perhaps +we should eta expand wherever we find a (value) lambda? Then the eta +expansion at a let RHS can concentrate solely on the PAP case. + +Note [In-scope set as a substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As per Note [Lookups in in-scope set], an in-scope set can act as +a substitution. Specifically, it acts as a substitution from variable to +variables /with the same unique/. + +Why do we need this? Well, during the course of the simplifier, we may want to +adjust inessential properties of a variable. For instance, when performing a +beta-reduction, we change + + (\x. e) u ==> let x = u in e + +We typically want to add an unfolding to `x` so that it inlines to (the +simplification of) `u`. + +We do that by adding the unfolding to the binder `x`, which is added to the +in-scope set. When simplifying occurrences of `x` (every occurrence!), they are +replaced by their “updated” version from the in-scope set, hence inherit the +unfolding. This happens in `SimplEnv.substId`. + +Another example. Consider + + case x of y { Node a b -> ...y... + ; Leaf v -> ...y... } + +In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we +want y's unfolding to be (Leaf v). We achieve this by adding the appropriate +unfolding to y, and re-adding it to the in-scope set. See the calls to +`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere. + +It's quite convenient. This way we don't need to manipulate the substitution all +the time: every update to a binder is automatically reflected to its bound +occurrences. + +Note [Bangs in the Simplifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Both SimplFloats and SimplEnv do *not* generally benefit from making +their fields strict. I don't know if this is because of good use of +laziness or unintended side effects like closures capturing more variables +after WW has run. + +But the end result is that we keep these lazy, but force them in some places +where we know it's beneficial to the compiler. + +Similarly environments returned from functions aren't *always* beneficial to +force. In some places they would never be demanded so forcing them early +increases allocation. In other places they almost always get demanded so +it's worthwhile to force them early. + +Would it be better to through every allocation of e.g. SimplEnv and decide +wether or not to make this one strict? Absolutely! Would be a good use of +someones time? Absolutely not! I made these strict that showed up during +a profiled build or which I noticed while looking at core for one reason +or another. + +The result sadly is that we end up with "random" bangs in the simplifier +where we sometimes force e.g. the returned environment from a function and +sometimes we don't for the same function. Depending on the context around +the call. The treatment is also not very consistent. I only added bangs +where I saw it making a difference either in the core or benchmarks. Some +patterns where it would be beneficial aren't convered as a consequence as +I neither have the time to go through all of the core and some cases are +too small to show up in benchmarks. + + + +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ +-} + +simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) +-- See Note [The big picture] +simplTopBinds env0 binds0 + = do { -- Put all the top-level binders into scope at the start + -- so that if a rewrite rule has unexpectedly brought + -- anything into scope, then we don't get a complaint about that. + -- It's rather as if the top-level binders were imported. + -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal". + -- See Note [Bangs in the Simplifier] + ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) + ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 + ; freeTick SimplifierDone + ; return (floats, env2) } + where + -- We need to track the zapped top-level binders, because + -- they should have their fragile IdInfo zapped (notably occurrence info) + -- That's why we run down binds and bndrs' simultaneously. + -- + simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) + simpl_binds env [] = return (emptyFloats env, env) + simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind + ; (floats, env2) <- simpl_binds env1 binds + -- See Note [Bangs in the Simplifier] + ; let !floats1 = float `addFloats` floats + ; return (floats1, env2) } + + simpl_bind env (Rec pairs) + = simplRecBind env (BC_Let TopLevel Recursive) pairs + simpl_bind env (NonRec b r) + = do { let bind_cxt = BC_Let TopLevel NonRecursive + ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt + ; simplRecOrTopPair env' bind_cxt b b' r } + +{- +************************************************************************ +* * + Lazy bindings +* * +************************************************************************ + +simplRecBind is used for + * recursive bindings only +-} + +simplRecBind :: SimplEnv -> BindContext + -> [(InId, InExpr)] + -> SimplM (SimplFloats, SimplEnv) +simplRecBind env0 bind_cxt pairs0 + = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0 + ; let new_bndrs = map sndOf3 triples + ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env -> + go env triples + ; return (mkRecFloats rec_floats, env2) } + where + add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) + -- Add the (substituted) rules to the binder + add_rules env (bndr, rhs) + = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt + ; return (env', (bndr, bndr', rhs)) } + + go env [] = return (emptyFloats env, env) + + go env ((old_bndr, new_bndr, rhs) : pairs) + = do { (float, env1) <- simplRecOrTopPair env bind_cxt + old_bndr new_bndr rhs + ; (floats, env2) <- go env1 pairs + ; return (float `addFloats` floats, env2) } + +{- +simplOrTopPair is used for + * recursive bindings (whether top level or not) + * top-level non-recursive bindings + +It assumes the binder has already been simplified, but not its IdInfo. +-} + +simplRecOrTopPair :: SimplEnv + -> BindContext + -> InId -> OutBndr -> InExpr -- Binder and rhs + -> SimplM (SimplFloats, SimplEnv) + +simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs + | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) + old_bndr rhs env + = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} + simplTrace "SimplBindr:inline-uncond" (ppr old_bndr) $ + do { tick (PreInlineUnconditionally old_bndr) + ; return ( emptyFloats env, env' ) } + + | otherwise + = case bind_cxt of + BC_Join cont -> simplTrace "SimplBind:join" (ppr old_bndr) $ + simplJoinBind env cont old_bndr new_bndr rhs env + + BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $ + simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env + +simplTrace :: String -> SDoc -> SimplM a -> SimplM a +simplTrace herald doc thing_inside = do + logger <- getLogger + if logHasDumpFlag logger Opt_D_verbose_core2core + then logTraceMsg logger herald doc thing_inside + else thing_inside + +-------------------------- +simplLazyBind :: SimplEnv + -> TopLevelFlag -> RecFlag + -> InId -> OutId -- Binder, both pre-and post simpl + -- Not a JoinId + -- The OutId has IdInfo, except arity, unfolding + -- Ids only, no TyVars + -> InExpr -> SimplEnv -- The RHS and its environment + -> SimplM (SimplFloats, SimplEnv) +-- Precondition: the OutId is already in the InScopeSet of the incoming 'env' +-- Precondition: not a JoinId +-- Precondition: rhs obeys the let-can-float invariant +-- NOT used for JoinIds +simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se + = assert (isId bndr ) + assertPpr (not (isJoinId bndr)) (ppr bndr) $ + -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ + do { let !rhs_env = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier] + (tvs, body) = case collectTyAndValBinders rhs of + (tvs, [], body) + | surely_not_lam body -> (tvs, body) + _ -> ([], rhs) + + surely_not_lam (Lam {}) = False + surely_not_lam (Tick t e) + | not (tickishFloatable t) = surely_not_lam e + -- eta-reduction could float + surely_not_lam _ = True + -- Do not do the "abstract tyvar" thing if there's + -- a lambda inside, because it defeats eta-reduction + -- f = /\a. \x. g a x + -- should eta-reduce. + + ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs + -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils + + -- Simplify the RHS + ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) + is_rec (idDemandInfo bndr) + ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont + + -- ANF-ise a constructor or PAP rhs + ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-} + prepareBinding env top_lvl is_rec + False -- Not strict; this is simplLazyBind + bndr1 body_floats0 body0 + -- Subtle point: we do not need or want tvs' in the InScope set + -- of body_floats2, so we pass in 'env' not 'body_env'. + -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do + -- more renaming than necessary => extra work (see !7777 and test T16577). + -- Don't need: we wrap tvs' around the RHS anyway. + + ; (rhs_floats, body3) + <- if isEmptyFloats body_floats2 || null tvs then -- Simple floating + {-#SCC "simplLazyBind-simple-floating" #-} + return (body_floats2, body2) + + else -- Non-empty floats, and non-empty tyvars: do type-abstraction first + {-#SCC "simplLazyBind-type-abstraction-first" #-} + do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl + tvs' body_floats2 body2 + ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds + ; return (poly_floats, body3) } + + ; let env' = env `setInScopeFromF` rhs_floats + ; rhs' <- rebuildLam env' tvs' body3 rhs_cont + ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs' + ; return (rhs_floats `addFloats` bind_float, env2) } + +-------------------------- +simplJoinBind :: SimplEnv + -> SimplCont + -> InId -> OutId -- Binder, both pre-and post simpl + -- The OutId has IdInfo, except arity, + -- unfolding + -> InExpr -> SimplEnv -- The right hand side and its env + -> SimplM (SimplFloats, SimplEnv) +simplJoinBind env cont old_bndr new_bndr rhs rhs_se + = do { let rhs_env = rhs_se `setInScopeFromE` env + ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont + ; completeBind env (BC_Join cont) old_bndr new_bndr rhs' } + +-------------------------- +simplNonRecX :: SimplEnv + -> InId -- Old binder; not a JoinId + -> OutExpr -- Simplified RHS + -> SimplM (SimplFloats, SimplEnv) +-- A specialised variant of simplNonRec used when the RHS is already +-- simplified, notably in knownCon. It uses case-binding where necessary. +-- +-- Precondition: rhs satisfies the let-can-float invariant + +simplNonRecX env bndr new_rhs + | assertPpr (not (isJoinId bndr)) (ppr bndr) $ + isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } + = return (emptyFloats env, env) -- Here c is dead, and we avoid + -- creating the binding c = (a,b) + + | Coercion co <- new_rhs + = return (emptyFloats env, extendCvSubst env bndr co) + + | exprIsTrivial new_rhs -- Short-cut for let x = y in ... + -- This case would ultimately land in postInlineUnconditionally + -- but it seems not uncommon, and avoids a lot of faff to do it here + = return (emptyFloats env + , extendIdSubst env bndr (DoneEx new_rhs Nothing)) + + | otherwise + = do { (env1, new_bndr) <- simplBinder env bndr + ; let is_strict = isStrictId new_bndr + -- isStrictId: use new_bndr because the InId bndr might not have + -- a fixed runtime representation, which isStrictId doesn't expect + -- c.f. Note [Dark corner with representation polymorphism] + + ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict + new_bndr (emptyFloats env) new_rhs + -- NB: it makes a surprisingly big difference (5% in compiler allocation + -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env', + -- because this is simplNonRecX, so bndr is not in scope in the RHS. + + ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats) + (BC_Let NotTopLevel NonRecursive) + bndr new_bndr rhs1 + -- Must pass env1 to completeBind in case simplBinder had to clone, + -- and extended the substitution with [bndr :-> new_bndr] + + ; return (rhs_floats `addFloats` bind_float, env2) } + + +{- ********************************************************************* +* * + Cast worker/wrapper +* * +************************************************************************ + +Note [Cast worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have a binding + x = e |> co +we want to do something very similar to worker/wrapper: + $wx = e + x = $wx |> co + +We call this making a cast worker/wrapper in tryCastWorkerWrapper. + +The main motivaiton is that x can be inlined freely. There's a chance +that e will be a constructor application or function, or something +like that, so moving the coercion to the usage site may well cancel +the coercions and lead to further optimisation. Example: + + data family T a :: * + data instance T Int = T Int + + foo :: Int -> Int -> Int + foo m n = ... + where + t = T m + go 0 = 0 + go n = case t of { T m -> go (n-m) } + -- This case should optimise + +A second reason for doing cast worker/wrapper is that the worker/wrapper +pass after strictness analysis can't deal with RHSs like + f = (\ a b c. blah) |> co +Instead, it relies on cast worker/wrapper to get rid of the cast, +leaving a simpler job for demand-analysis worker/wrapper. See #19874. + +Wrinkles + +1. We must /not/ do cast w/w on + f = g |> co + otherwise it'll just keep repeating forever! You might think this + is avoided because the call to tryCastWorkerWrapper is guarded by + preInlineUnconditinally, but I'm worried that a loop-breaker or an + exported Id might say False to preInlineUnonditionally. + +2. We need to be careful with inline/noinline pragmas: + rec { {-# NOINLINE f #-} + f = (...g...) |> co + ; g = ...f... } + This is legitimate -- it tells GHC to use f as the loop breaker + rather than g. Now we do the cast thing, to get something like + rec { $wf = ...g... + ; f = $wf |> co + ; g = ...f... } + Where should the NOINLINE pragma go? If we leave it on f we'll get + rec { $wf = ...g... + ; {-# NOINLINE f #-} + f = $wf |> co + ; g = ...f... } + and that is bad: the whole point is that we want to inline that + cast! We want to transfer the pagma to $wf: + rec { {-# NOINLINE $wf #-} + $wf = ...g... + ; f = $wf |> co + ; g = ...f... } + c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + +3. We should still do cast w/w even if `f` is INLINEABLE. E.g. + {- f: Stable unfolding = <stable-big> -} + f = (\xy. <big-body>) |> co + Then we want to w/w to + {- $wf: Stable unfolding = <stable-big> |> sym co -} + $wf = \xy. <big-body> + f = $wf |> co + Notice that the stable unfolding moves to the worker! Now demand analysis + will work fine on $wf, whereas it has trouble with the original f. + c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap. + This point also applies to strong loopbreakers with INLINE pragmas, see + wrinkle (4). + +4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence + hasInlineUnfolding in tryCastWorkerWrapper, which responds False to + loop-breakers) because they'll definitely be inlined anyway, cast and + all. And if we do cast w/w for an INLINE function with arity zero, we get + something really silly: we inline that "worker" right back into the wrapper! + Worse than a no-op, because we have then lost the stable unfolding. + +All these wrinkles are exactly like worker/wrapper for strictness analysis: + f is the wrapper and must inline like crazy + $wf is the worker and must carry f's original pragma +See Note [Worker/wrapper for INLINABLE functions] +and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + +See #17673, #18093, #18078, #19890. + +Note [Preserve strictness in cast w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the Note [Cast worker/wrapper] transformation, keep the strictness info. +Eg + f = e `cast` co -- f has strictness SSL +When we transform to + f' = e -- f' also has strictness SSL + f = f' `cast` co -- f still has strictness SSL + +Its not wrong to drop it on the floor, but better to keep it. + +Note [Preserve RuntimeRep info in cast w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must not do cast w/w when the presence of the coercion is needed in order +to determine the runtime representation. + +Example: + + Suppose we have a type family: + + type F :: RuntimeRep + type family F where + F = LiftedRep + + together with a type `ty :: TYPE F` and a top-level binding + + a :: ty |> TYPE F[0] + + The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding. + However, were we to apply cast w/w, we would get: + + b :: ty + b = ... + + a :: ty |> TYPE F[0] + a = b `cast` GRefl (TYPE F[0]) + + Now we are in trouble because `ty :: TYPE F` does not have a known runtime + representation, because we need to be able to reduce the nullary type family + application `F` to find that out. + +Conclusion: only do cast w/w when doing so would not lose the RuntimeRep +information. That is, when handling `Cast rhs co`, don't attempt cast w/w +unless the kind of the type of rhs is concrete, in the sense of +Note [Concrete types] in GHC.Tc.Utils.Concrete. +-} + +tryCastWorkerWrapper :: SimplEnv -> BindContext + -> InId -> OccInfo + -> OutId -> OutExpr + -> SimplM (SimplFloats, SimplEnv) +-- See Note [Cast worker/wrapper] +tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co) + | BC_Let top_lvl is_rec <- bind_cxt -- Not join points + , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform + -- a DFunUnfolding in mk_worker_unfolding + , not (exprIsTrivial rhs) -- Not x = y |> co; Wrinkle 1 + , not (hasInlineUnfolding info) -- Not INLINE things: Wrinkle 4 + , isConcrete (typeKind work_ty) -- Don't peel off a cast if doing so would + -- lose the underlying runtime representation. + -- See Note [Preserve RuntimeRep info in cast w/w] + , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings + -- See Note [OPAQUE pragma] + = do { uniq <- getUniqueM + ; let work_name = mkSystemVarName uniq occ_fs + work_id = mkLocalIdWithInfo work_name Many work_ty work_info + is_strict = isStrictId bndr + + ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict + work_id (emptyFloats env) rhs + + ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs + ; let work_id_w_unf = work_id `setIdUnfolding` work_unf + floats = rhs_floats `addLetFloats` + unitLetFloat (NonRec work_id_w_unf work_rhs) + + triv_rhs = Cast (Var work_id_w_unf) co + + ; if postInlineUnconditionally env bind_cxt bndr occ_info triv_rhs + -- Almost always True, because the RHS is trivial + -- In that case we want to eliminate the binding fast + -- We conservatively use postInlineUnconditionally so that we + -- check all the right things + then do { tick (PostInlineUnconditionally bndr) + ; return ( floats + , extendIdSubst (setInScopeFromF env floats) old_bndr $ + DoneEx triv_rhs Nothing ) } + + else do { wrap_unf <- mkLetUnfolding uf_opts top_lvl InlineRhs bndr triv_rhs + ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr) + `setIdUnfolding` wrap_unf + floats' = floats `extendFloats` NonRec bndr' triv_rhs + ; return ( floats', setInScopeFromF env floats' ) } } + where + occ_fs = getOccFS bndr + uf_opts = seUnfoldingOpts env + work_ty = coercionLKind co + info = idInfo bndr + work_arity = arityInfo info `min` typeArity work_ty + + work_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info + `setCprSigInfo` cprSigInfo info + `setDemandInfo` demandInfo info + `setInlinePragInfo` inlinePragInfo info + `setArityInfo` work_arity + -- We do /not/ want to transfer OccInfo, Rules + -- Note [Preserve strictness in cast w/w] + -- and Wrinkle 2 of Note [Cast worker/wrapper] + + ----------- Worker unfolding ----------- + -- Stable case: if there is a stable unfolding we have to compose with (Sym co); + -- the next round of simplification will do the job + -- Non-stable case: use work_rhs + -- Wrinkle 3 of Note [Cast worker/wrapper] + mk_worker_unfolding top_lvl work_id work_rhs + = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) }) + _ -> mkLetUnfolding uf_opts top_lvl InlineRhs work_id work_rhs + +tryCastWorkerWrapper env _ _ _ bndr rhs -- All other bindings + = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr + , text "rhs:" <+> ppr rhs ]) + ; return (mkFloatBind env (NonRec bndr rhs)) } + +mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma +-- See Note [Cast worker/wrapper] +mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) + = InlinePragma { inl_src = SourceText "{-# INLINE" + , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag] + , inl_sat = Nothing -- in GHC.Core.Opt.WorkWrap + , inl_act = wrap_act -- See Note [Wrapper activation] + , inl_rule = rule_info } -- in GHC.Core.Opt.WorkWrap + -- RuleMatchInfo is (and must be) unaffected + where + -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap + -- But simpler, because we don't need to disable during InitialPhase + wrap_act | isNeverActive act = activateDuringFinal + | otherwise = act + + +{- ********************************************************************* +* * + prepareBinding, prepareRhs, makeTrivial +* * +********************************************************************* -} + +prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool + -> Id -- Used only for its OccName; can be InId or OutId + -> SimplFloats -> OutExpr + -> SimplM (SimplFloats, OutExpr) +-- In (prepareBinding ... bndr floats rhs), the binding is really just +-- bndr = let floats in rhs +-- Maybe we can ANF-ise this binding and float out; e.g. +-- bndr = let a = f x in K a a (g x) +-- we could float out to give +-- a = f x +-- tmp = g x +-- bndr = K a a tmp +-- That's what prepareBinding does +-- Precondition: binder is not a JoinId +-- Postcondition: the returned SimplFloats contains only let-floats +prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs + = do { -- Never float join-floats out of a non-join let-binding (which this is) + -- So wrap the body in the join-floats right now + -- Hence: rhs_floats1 consists only of let-floats + let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs + + -- rhs_env: add to in-scope set the binders from rhs_floats + -- so that prepareRhs knows what is in scope in rhs + ; let rhs_env = env `setInScopeFromF` rhs_floats1 + + -- Now ANF-ise the remaining rhs + ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl (getOccFS bndr) rhs1 + + -- Finally, decide whether or not to float + ; let all_floats = rhs_floats1 `addLetFloats` anf_floats + ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2 + then -- Float! + do { tick LetFloatFromLet + ; return (all_floats, rhs2) } + + else -- Abandon floating altogether; revert to original rhs + -- Since we have already built rhs1, we just need to add + -- rhs_floats1 to it + return (emptyFloats env, wrapFloats rhs_floats1 rhs1) } + +{- Note [prepareRhs] +~~~~~~~~~~~~~~~~~~~~ +prepareRhs takes a putative RHS, checks whether it's a PAP or +constructor application and, if so, converts it to ANF, so that the +resulting thing can be inlined more easily. Thus + x = (f a, g b) +becomes + t1 = f a + t2 = g b + x = (t1,t2) + +We also want to deal well cases like this + v = (f e1 `cast` co) e2 +Here we want to make e1,e2 trivial and get + x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 +That's what the 'go' loop in prepareRhs does +-} + +prepareRhs :: HasDebugCallStack + => SimplEnv -> TopLevelFlag + -> FastString -- Base for any new variables + -> OutExpr + -> SimplM (LetFloats, OutExpr) +-- Transforms a RHS into a better RHS by ANF'ing args +-- for expandable RHSs: constructors and PAPs +-- e.g x = Just e +-- becomes a = e -- 'a' is fresh +-- x = Just a +-- See Note [prepareRhs] +prepareRhs env top_lvl occ rhs0 + = do { (_is_exp, floats, rhs1) <- go 0 rhs0 + ; return (floats, rhs1) } + where + go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr) + go n_val_args (Cast rhs co) + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; return (is_exp, floats, Cast rhs' co) } + go n_val_args (App fun (Type ty)) + = do { (is_exp, floats, rhs') <- go n_val_args fun + ; return (is_exp, floats, App rhs' (Type ty)) } + go n_val_args (App fun arg) + = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun + ; if is_exp + then do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg + ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } + else return (False, emptyLetFloats, App fun arg) + } + go n_val_args (Var fun) + = return (is_exp, emptyLetFloats, Var fun) + where + is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP + -- See Note [CONLIKE pragma] in GHC.Types.Basic + -- The definition of is_exp should match that in + -- 'GHC.Core.Opt.OccurAnal.occAnalApp' + + go n_val_args (Tick t rhs) + -- We want to be able to float bindings past this + -- tick. Non-scoping ticks don't care. + | tickishScoped t == NoScope + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; return (is_exp, floats, Tick t rhs') } + + -- On the other hand, for scoping ticks we need to be able to + -- copy them on the floats, which in turn is only allowed if + -- we can obtain non-counting ticks. + | (not (tickishCounts t) || tickishCanSplit t) + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) + floats' = mapLetFloats floats tickIt + ; return (is_exp, floats', Tick t rhs') } + + go _ other + = return (False, emptyLetFloats, other) + +makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec) +makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd }) + = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e + ; return (floats, arg { as_arg = e' }) } +makeTrivialArg _ arg + = return (emptyLetFloats, arg) -- CastBy, TyArg + +makeTrivial :: HasDebugCallStack + => SimplEnv -> TopLevelFlag -> Demand + -> FastString -- ^ A "friendly name" to build the new binder from + -> OutExpr + -> SimplM (LetFloats, OutExpr) +-- Binds the expression to a variable, if it's not trivial, returning the variable +-- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A] +makeTrivial env top_lvl dmd occ_fs expr + | exprIsTrivial expr -- Already trivial + || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + -- See Note [Cannot trivialise] + = return (emptyLetFloats, expr) + + | Cast expr' co <- expr + = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr' + ; return (floats, Cast triv_expr co) } + + | otherwise -- 'expr' is not of form (Cast e co) + = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr + ; uniq <- getUniqueM + ; let name = mkSystemVarName uniq occ_fs + var = mkLocalIdWithInfo name Many expr_ty id_info + + -- Now something very like completeBind, + -- but without the postInlineUnconditionally part + ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1 + -- Technically we should extend the in-scope set in 'env' with + -- the 'floats' from prepareRHS; but they are all fresh, so there is + -- no danger of introducing name shadowig in eta expansion + + ; unf <- mkLetUnfolding uf_opts top_lvl InlineRhs var expr2 + + ; let final_id = addLetBndrInfo var arity_type unf + bind = NonRec final_id expr2 + + ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ]) + ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) } + where + id_info = vanillaIdInfo `setDemandInfo` dmd + expr_ty = exprType expr + uf_opts = seUnfoldingOpts env + +bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool +-- True iff we can have a binding of this expression at this level +-- Precondition: the type is the type of the expression +bindingOk top_lvl expr expr_ty + | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty + | otherwise = True + +{- Note [Cannot trivialise] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + f :: Int -> Addr# + + foo :: Bar + foo = Bar (f 3) + +Then we can't ANF-ise foo, even though we'd like to, because +we can't make a top-level binding for the Addr# (f 3). And if +so we don't want to turn it into + foo = let x = f 3 in Bar x +because we'll just end up inlining x back, and that makes the +simplifier loop. Better not to ANF-ise it at all. + +Literal strings are an exception. + + foo = Ptr "blob"# + +We want to turn this into: + + foo1 = "blob"# + foo = Ptr foo1 + +See Note [Core top-level string literals] in GHC.Core. + +************************************************************************ +* * + Completing a lazy binding +* * +************************************************************************ + +completeBind + * deals only with Ids, not TyVars + * takes an already-simplified binder and RHS + * is used for both recursive and non-recursive bindings + * is used for both top-level and non-top-level bindings + +It does the following: + - tries discarding a dead binding + - tries PostInlineUnconditionally + - add unfolding [this is the only place we add an unfolding] + - add arity + - extend the InScopeSet of the SimplEnv + +It does *not* attempt to do let-to-case. Why? Because it is used for + - top-level bindings (when let-to-case is impossible) + - many situations where the "rhs" is known to be a WHNF + (so let-to-case is inappropriate). + +Nor does it do the atomic-argument thing +-} + +completeBind :: SimplEnv + -> BindContext + -> InId -- Old binder + -> OutId -- New binder; can be a JoinId + -> OutExpr -- New RHS + -> SimplM (SimplFloats, SimplEnv) +-- completeBind may choose to do its work +-- * by extending the substitution (e.g. let x = y in ...) +-- * or by adding to the floats in the envt +-- +-- Binder /can/ be a JoinId +-- Precondition: rhs obeys the let-can-float invariant +completeBind env bind_cxt old_bndr new_bndr new_rhs + | isCoVar old_bndr + = case new_rhs of + Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) + _ -> return (mkFloatBind env (NonRec new_bndr new_rhs)) + + | otherwise + = assert (isId new_bndr) $ + do { let old_info = idInfo old_bndr + old_unf = realUnfoldingInfo old_info + occ_info = occInfo old_info + + -- Do eta-expansion on the RHS of the binding + -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils + ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs + + -- Simplify the unfolding + ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr + eta_rhs (idType new_bndr) new_arity old_unf + + ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding + -- See Note [In-scope set as a substitution] + + ; if postInlineUnconditionally env bind_cxt new_bndr_w_info occ_info eta_rhs + + then -- Inline and discard the binding + do { tick (PostInlineUnconditionally old_bndr) + ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs + -- See Note [Use occ-anald RHS in postInlineUnconditionally] + ; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $ + return ( emptyFloats env + , extendIdSubst env old_bndr $ + DoneEx unf_rhs (isJoinId_maybe new_bndr)) } + -- Use the substitution to make quite, quite sure that the + -- substitution will happen, since we are going to discard the binding + + else -- Keep the binding; do cast worker/wrapper + -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $ + tryCastWorkerWrapper env bind_cxt old_bndr occ_info new_bndr_w_info eta_rhs } + +addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId +addLetBndrInfo new_bndr new_arity_type new_unf + = new_bndr `setIdInfo` info5 + where + new_arity = arityTypeArity new_arity_type + info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unf + + -- Demand info: Note [Setting the demand info] + info3 | isEvaldUnfolding new_unf + = zapDemandInfo info2 `orElse` info2 + | otherwise + = info2 + + -- Bottoming bindings: see Note [Bottoming bindings] + info4 = case getBotArity new_arity_type of + Nothing -> info3 + Just ar -> assert (ar == new_arity) $ + info3 `setDmdSigInfo` mkVanillaDmdSig new_arity botDiv + `setCprSigInfo` mkCprSig new_arity botCpr + + -- Zap call arity info. We have used it by now (via + -- `tryEtaExpandRhs`), and the simplifier can invalidate this + -- information, leading to broken code later (e.g. #13479) + info5 = zapCallArityInfo info4 + + +{- Note [Bottoming bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + let x = error "urk" + in ...(case x of <alts>)... +or + let f = \y. error (y ++ "urk") + in ...(case f "foo" of <alts>)... + +Then we'd like to drop the dead <alts> immediately. So it's good to +propagate the info that x's (or f's) RHS is bottom to x's (or f's) +IdInfo as rapidly as possible. + +We use tryEtaExpandRhs on every binding, and it turns out that the +arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already +does a simple bottoming-expression analysis. So all we need to do +is propagate that info to the binder's IdInfo. + +This showed up in #12150; see comment:16. + +There is a second reason for settting the strictness signature. Consider + let -- f :: <[S]b> + f = \x. error "urk" + in ...(f a b c)... +Then, in GHC.Core.Opt.Arity.findRhsArity we'll use the demand-info on `f` +to eta-expand to + let f = \x y z. error "urk" + in ...(f a b c)... + +But now f's strictness signature has too short an arity; see +GHC.Core.Opt.DmdAnal Note [idArity varies independently of dmdTypeDepth]. +Fortuitously, the same strictness-signature-fixup code +gives the function a new strictness signature with the right number of +arguments. Example in stranal/should_compile/EtaExpansion. + +Note [Setting the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the unfolding is a value, the demand info may +go pear-shaped, so we nuke it. Example: + let x = (a,b) in + case x of (p,q) -> h p q x +Here x is certainly demanded. But after we've nuked +the case, we'll get just + let x = (a,b) in h a b x +and now x is not demanded (I'm assuming h is lazy) +This really happens. Similarly + let f = \x -> e in ...f..f... +After inlining f at some of its call sites the original binding may +(for example) be no longer strictly demanded. +The solution here is a bit ad hoc... + +Note [Use occ-anald RHS in postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we postInlineUnconditionally 'f in + let f = \x -> x True in ...(f blah)... +then we'd like to inline the /occ-anald/ RHS for 'f'. If we +use the non-occ-anald version, we'll end up with a + ...(let x = blah in x True)... +and hence an extra Simplifier iteration. + +We already /have/ the occ-anald version in the Unfolding for +the Id. Well, maybe not /quite/ always. If the binder is Dead, +postInlineUnconditionally will return True, but we may not have an +unfolding because it's too big. Hence the belt-and-braces `orElse` +in the defn of unf_rhs. The Nothing case probably never happens. + + +************************************************************************ +* * +\subsection[Simplify-simplExpr]{The main function: simplExpr} +* * +************************************************************************ + +The reason for this OutExprStuff stuff is that we want to float *after* +simplifying a RHS, not before. If we do so naively we get quadratic +behaviour as things float out. + +To see why it's important to do it after, consider this (real) example: + + let t = f x + in fst t +==> + let t = let a = e1 + b = e2 + in (a,b) + in fst t +==> + let a = e1 + b = e2 + t = (a,b) + in + a -- Can't inline a this round, cos it appears twice +==> + e1 + +Each of the ==> steps is a round of simplification. We'd save a +whole round if we float first. This can cascade. Consider + + let f = g d + in \x -> ...f... +==> + let f = let d1 = ..d.. in \y -> e + in \x -> ...f... +==> + let d1 = ..d.. + in \x -> ...(\y ->e)... + +Only in this second round can the \y be applied, and it +might do the same again. +-} + +simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr +simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier] + = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType] + ; return (Type ty') } + +simplExpr env expr + = simplExprC env expr (mkBoringStop expr_out_ty) + where + expr_out_ty :: OutType + expr_out_ty = substTy env (exprType expr) + -- NB: Since 'expr' is term-valued, not (Type ty), this call + -- to exprType will succeed. exprType fails on (Type ty). + +simplExprC :: SimplEnv + -> InExpr -- A term-valued expression, never (Type ty) + -> SimplCont + -> SimplM OutExpr + -- Simplify an expression, given a continuation +simplExprC env expr cont + = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $ + do { (floats, expr') <- simplExprF env expr cont + ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ + -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ + -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $ + return (wrapFloats floats expr') } + +-------------------------------------------------- +simplExprF :: SimplEnv + -> InExpr -- A term-valued expression, never (Type ty) + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplExprF !env e !cont -- See Note [Bangs in the Simplifier] + = {- pprTrace "simplExprF" (vcat + [ ppr e + , text "cont =" <+> ppr cont + , text "inscope =" <+> ppr (seInScope env) + , text "tvsubst =" <+> ppr (seTvSubst env) + , text "idsubst =" <+> ppr (seIdSubst env) + , text "cvsubst =" <+> ppr (seCvSubst env) + ]) $ -} + simplExprF1 env e cont + +simplExprF1 :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplExprF1 _ (Type ty) cont + = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont) + -- simplExprF does only with term-valued expressions + -- The (Type ty) case is handled separately by simplExpr + -- and by the other callers of simplExprF + +simplExprF1 env (Var v) cont = {-#SCC "simplIdF" #-} simplIdF env v cont +simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont +simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont +simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont +simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont + +simplExprF1 env (App fun arg) cont + = {-#SCC "simplExprF1-App" #-} case arg of + Type ty -> do { -- The argument type will (almost) certainly be used + -- in the output program, so just force it now. + -- See Note [Avoiding space leaks in OutType] + arg' <- simplType env ty + + -- But use substTy, not simplType, to avoid forcing + -- the hole type; it will likely not be needed. + -- See Note [The hole type in ApplyToTy] + ; let hole' = substTy env (exprType fun) + + ; simplExprF env fun $ + ApplyToTy { sc_arg_ty = arg' + , sc_hole_ty = hole' + , sc_cont = cont } } + _ -> + -- Crucially, sc_hole_ty is a /lazy/ binding. It will + -- be forced only if we need to run contHoleType. + -- When these are forced, we might get quadratic behavior; + -- this quadratic blowup could be avoided by drilling down + -- to the function and getting its multiplicities all at once + -- (instead of one-at-a-time). But in practice, we have not + -- observed the quadratic behavior, so this extra entanglement + -- seems not worthwhile. + simplExprF env fun $ + ApplyToVal { sc_arg = arg, sc_env = env + , sc_hole_ty = substTy env (exprType fun) + , sc_dup = NoDup, sc_cont = cont } + +simplExprF1 env expr@(Lam {}) cont + = {-#SCC "simplExprF1-Lam" #-} + simplLam env (zapLambdaBndrs expr n_args) cont + -- zapLambdaBndrs: the issue here is under-saturated lambdas + -- (\x1. \x2. e) arg1 + -- Here x1 might have "occurs-once" occ-info, because occ-info + -- is computed assuming that a group of lambdas is applied + -- all at once. If there are too few args, we must zap the + -- occ-info, UNLESS the remaining binders are one-shot + where + n_args = countArgs cont + -- NB: countArgs counts all the args (incl type args) + -- and likewise drop counts all binders (incl type lambdas) + +simplExprF1 env (Case scrut bndr _ alts) cont + = {-#SCC "simplExprF1-Case" #-} + simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr + , sc_alts = alts + , sc_env = env, sc_cont = cont }) + +simplExprF1 env (Let (Rec pairs) body) cont + | Just pairs' <- joinPointBindings_maybe pairs + = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont + + | otherwise + = {-#SCC "simplRecE" #-} simplRecE env pairs body cont + +simplExprF1 env (Let (NonRec bndr rhs) body) cont + | Type ty <- rhs -- First deal with type lets (let a = Type ty in e) + = {-#SCC "simplExprF1-NonRecLet-Type" #-} + assert (isTyVar bndr) $ + do { ty' <- simplType env ty + ; simplExprF (extendTvSubst env bndr ty') body cont } + + | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs + = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont + + | otherwise + = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) body cont + +{- Note [Avoiding space leaks in OutType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the simplifier is run for multiple iterations, we need to ensure +that any thunks in the output of one simplifier iteration are forced +by the evaluation of the next simplifier iteration. Otherwise we may +retain multiple copies of the Core program and leak a terrible amount +of memory (as in #13426). + +The simplifier is naturally strict in the entire "Expr part" of the +input Core program, because any expression may contain binders, which +we must find in order to extend the SimplEnv accordingly. But types +do not contain binders and so it is tempting to write things like + + simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad! + +This is Bad because the result includes a thunk (substTy env ty) which +retains a reference to the whole simplifier environment; and the next +simplifier iteration will not force this thunk either, because the +line above is not strict in ty. + +So instead our strategy is for the simplifier to fully evaluate +OutTypes when it emits them into the output Core program, for example + + simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good + ; return (Type ty') } + +where the only difference from above is that simplType calls seqType +on the result of substTy. + +However, SimplCont can also contain OutTypes and it's not necessarily +a good idea to force types on the way in to SimplCont, because they +may end up not being used and forcing them could be a lot of wasted +work. T5631 is a good example of this. + +- For ApplyToTy's sc_arg_ty, we force the type on the way in because + the type will almost certainly appear as a type argument in the + output program. + +- For the hole types in Stop and ApplyToTy, we force the type when we + emit it into the output program, after obtaining it from + contResultType. (The hole type in ApplyToTy is only directly used + to form the result type in a new Stop continuation.) +-} + +--------------------------------- +-- Simplify a join point, adding the context. +-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do: +-- \x1 .. xn -> e => \x1 .. xn -> E[e] +-- Note that we need the arity of the join point, since e may be a lambda +-- (though this is unlikely). See Note [Join points and case-of-case]. +simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont + -> SimplM OutExpr +simplJoinRhs env bndr expr cont + | Just arity <- isJoinId_maybe bndr + = do { let (join_bndrs, join_body) = collectNBinders arity expr + mult = contHoleScaling cont + ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs) + ; join_body' <- simplExprC env' join_body cont + ; return $ mkLams join_bndrs' join_body' } + + | otherwise + = pprPanic "simplJoinRhs" (ppr bndr) + +--------------------------------- +simplType :: SimplEnv -> InType -> SimplM OutType + -- Kept monadic just so we can do the seqType + -- See Note [Avoiding space leaks in OutType] +simplType env ty + = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ + seqType new_ty `seq` return new_ty + where + new_ty = substTy env ty + +--------------------------------- +simplCoercionF :: SimplEnv -> InCoercion -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplCoercionF env co cont + = do { co' <- simplCoercion env co + ; rebuild env (Coercion co') cont } + +simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion +simplCoercion env co + = do { let opt_co = optCoercion opts (getTCvSubst env) co + ; seqCo opt_co `seq` return opt_co } + where + opts = seOptCoercionOpts env + +----------------------------------- +-- | Push a TickIt context outwards past applications and cases, as +-- long as this is a non-scoping tick, to let case and application +-- optimisations apply. + +simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplTick env tickish expr cont + -- A scoped tick turns into a continuation, so that we can spot + -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do + -- it this way, then it would take two passes of the simplifier to + -- reduce ((scc t (\x . e)) e'). + -- NB, don't do this with counting ticks, because if the expr is + -- bottom, then rebuildCall will discard the continuation. + +-- XXX: we cannot do this, because the simplifier assumes that +-- the context can be pushed into a case with a single branch. e.g. +-- scc<f> case expensive of p -> e +-- becomes +-- case expensive of p -> scc<f> e +-- +-- So I'm disabling this for now. It just means we will do more +-- simplifier iterations that necessary in some cases. + +-- | tickishScoped tickish && not (tickishCounts tickish) +-- = simplExprF env expr (TickIt tickish cont) + + -- For unscoped or soft-scoped ticks, we are allowed to float in new + -- cost, so we simply push the continuation inside the tick. This + -- has the effect of moving the tick to the outside of a case or + -- application context, allowing the normal case and application + -- optimisations to fire. + | tickish `tickishScopesLike` SoftScope + = do { (floats, expr') <- simplExprF env expr cont + ; return (floats, mkTick tickish expr') + } + + -- Push tick inside if the context looks like this will allow us to + -- do a case-of-case - see Note [case-of-scc-of-case] + | Select {} <- cont, Just expr' <- push_tick_inside + = simplExprF env expr' cont + + -- We don't want to move the tick, but we might still want to allow + -- floats to pass through with appropriate wrapping (or not, see + -- wrap_floats below) + --- | not (tickishCounts tickish) || tickishCanSplit tickish + -- = wrap_floats + + | otherwise + = no_floating_past_tick + + where + + -- Try to push tick inside a case, see Note [case-of-scc-of-case]. + push_tick_inside = + case expr0 of + Case scrut bndr ty alts + -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) + _other -> Nothing + where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) + movable t = not (tickishCounts t) || + t `tickishScopesLike` NoScope || + tickishCanSplit t + tickScrut e = foldr mkTick e ticks + -- Alternatives get annotated with all ticks that scope in some way, + -- but we don't want to count entries. + tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope) + ts_scope = map mkNoCount $ + filter (not . (`tickishScopesLike` NoScope)) ticks + + no_floating_past_tick = + do { let (inc,outc) = splitCont cont + ; (floats, expr1) <- simplExprF env expr inc + ; let expr2 = wrapFloats floats expr1 + tickish' = simplTickish env tickish + ; rebuild env (mkTick tickish' expr2) outc + } + +-- Alternative version that wraps outgoing floats with the tick. This +-- results in ticks being duplicated, as we don't make any attempt to +-- eliminate the tick if we re-inline the binding (because the tick +-- semantics allows unrestricted inlining of HNFs), so I'm not doing +-- this any more. FloatOut will catch any real opportunities for +-- floating. +-- +-- wrap_floats = +-- do { let (inc,outc) = splitCont cont +-- ; (env', expr') <- simplExprF (zapFloats env) expr inc +-- ; let tickish' = simplTickish env tickish +-- ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0), +-- mkTick (mkNoCount tickish') rhs) +-- -- when wrapping a float with mkTick, we better zap the Id's +-- -- strictness info and arity, because it might be wrong now. +-- ; let env'' = addFloats env (mapFloats env' wrap_float) +-- ; rebuild env'' expr' (TickIt tickish' outc) +-- } + + + simplTickish env tickish + | Breakpoint ext n ids <- tickish + = Breakpoint ext n (map (getDoneId . substId env) ids) + | otherwise = tickish + + -- Push type application and coercion inside a tick + splitCont :: SimplCont -> (SimplCont, SimplCont) + splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) + where (inc,outc) = splitCont tail + splitCont (CastIt co c) = (CastIt co inc, outc) + where (inc,outc) = splitCont c + splitCont other = (mkBoringStop (contHoleType other), other) + + getDoneId (DoneId id) = id + getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst + getDoneId other = pprPanic "getDoneId" (ppr other) + +-- Note [case-of-scc-of-case] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- It's pretty important to be able to transform case-of-case when +-- there's an SCC in the way. For example, the following comes up +-- in nofib/real/compress/Encode.hs: +-- +-- case scctick<code_string.r1> +-- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje +-- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) -> +-- (ww1_s13f, ww2_s13g, ww3_s13h) +-- } +-- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) -> +-- tick<code_string.f1> +-- (ww_s12Y, +-- ww1_s12Z, +-- PTTrees.PT +-- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf) +-- } +-- +-- We really want this case-of-case to fire, because then the 3-tuple +-- will go away (indeed, the CPR optimisation is relying on this +-- happening). But the scctick is in the way - we need to push it +-- inside to expose the case-of-case. So we perform this +-- transformation on the inner case: +-- +-- scctick c (case e of { p1 -> e1; ...; pn -> en }) +-- ==> +-- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en } +-- +-- So we've moved a constant amount of work out of the scc to expose +-- the case. We only do this when the continuation is interesting: in +-- for now, it has to be another Case (maybe generalise this later). + +{- +************************************************************************ +* * +\subsection{The main rebuilder} +* * +************************************************************************ +-} + +rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) +-- At this point the substitution in the SimplEnv should be irrelevant; +-- only the in-scope set matters +rebuild env expr cont + = case cont of + Stop {} -> return (emptyFloats env, expr) + TickIt t cont -> rebuild env (mkTick t expr) cont + CastIt co cont -> rebuild env (mkCast expr co) cont + -- NB: mkCast implements the (Coercion co |> g) optimisation + + Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } + -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont + + StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty } + -> rebuildCall env (addValArgTo fun expr fun_ty ) cont + + StrictBind { sc_bndr = b, sc_body = body, sc_env = se, sc_cont = cont } + -> completeBindX (se `setInScopeFromE` env) b expr body cont + + ApplyToTy { sc_arg_ty = ty, sc_cont = cont} + -> rebuild env (App expr (Type ty)) cont + + ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont} + -- See Note [Avoid redundant simplification] + -> do { (_, _, arg') <- simplArg env dup_flag se arg + ; rebuild env (App expr arg') cont } + +completeBindX :: SimplEnv + -> InId -> OutExpr -- Bind this Id to this (simplified) expression + -- (the let-can-float invariant may not be satisfied) + -> InExpr -- In this lambda + -> SimplCont -- Consumed by this continuation + -> SimplM (SimplFloats, OutExpr) +completeBindX env bndr rhs body cont + | needsCaseBinding (idType bndr) rhs -- Enforcing the let-can-float-invariant + = do { (env1, bndr1) <- simplNonRecBndr env bndr + ; (floats, expr') <- simplLam env1 body cont + -- Do not float floats past the Case binder below + ; let expr'' = wrapFloats floats expr' + ; let case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr''] + ; return (emptyFloats env, case_expr) } + + | otherwise + = do { (floats1, env') <- simplNonRecX env bndr rhs + ; (floats2, expr') <- simplLam env' body cont + ; return (floats1 `addFloats` floats2, expr') } + + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +{- Note [Optimising reflexivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important (for compiler performance) to get rid of reflexivity as soon +as it appears. See #11735, #14737, and #15019. + +In particular, we want to behave well on + + * e |> co1 |> co2 + where the two happen to cancel out entirely. That is quite common; + e.g. a newtype wrapping and unwrapping cancel. + + + * (f |> co) @t1 @t2 ... @tn x1 .. xm + Here we will use pushCoTyArg and pushCoValArg successively, which + build up NthCo stacks. Silly to do that if co is reflexive. + +However, we don't want to call isReflexiveCo too much, because it uses +type equality which is expensive on big types (#14737 comment:7). + +A good compromise (determined experimentally) seems to be to call +isReflexiveCo + * when composing casts, and + * at the end + +In investigating this I saw missed opportunities for on-the-fly +coercion shrinkage. See #15090. +-} + + +simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplCast env body co0 cont0 + = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 + ; cont1 <- {-#SCC "simplCast-addCoerce" #-} + if isReflCo co1 + then return cont0 -- See Note [Optimising reflexivity] + else addCoerce co1 cont0 + ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } + where + -- If the first parameter is MRefl, then simplifying revealed a + -- reflexive coercion. Omit. + addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont + addCoerceM MRefl cont = return cont + addCoerceM (MCo co) cont = addCoerce co cont + + addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont + addCoerce co1 (CastIt co2 cont) -- See Note [Optimising reflexivity] + | isReflexiveCo co' = return cont + | otherwise = addCoerce co' cont + where + co' = mkTransCo co1 co2 + + addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) + | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty + = {-#SCC "addCoerce-pushCoTyArg" #-} + do { tail' <- addCoerceM m_co' tail + ; return (ApplyToTy { sc_arg_ty = arg_ty' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } + -- NB! As the cast goes past, the + -- type of the hole changes (#16312) + + -- (f |> co) e ===> (f (e |> co1)) |> co2 + -- where co :: (s1->s2) ~ (t1->t2) + -- co1 :: t1 ~ s1 + -- co2 :: s2 ~ t2 + addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup, sc_cont = tail }) + | Just (m_co1, m_co2) <- pushCoValArg co + , fixed_rep m_co1 + = {-#SCC "addCoerce-pushCoValArg" #-} + do { tail' <- addCoerceM m_co2 tail + ; case m_co1 of { + MRefl -> return (cont { sc_cont = tail' + , sc_hole_ty = coercionLKind co }) ; + -- Avoid simplifying if possible; + -- See Note [Avoiding exponential behaviour] + + MCo co1 -> + do { (dup', arg_se', arg') <- simplArg env dup arg_se arg + -- When we build the ApplyTo we can't mix the OutCoercion + -- 'co' with the InExpr 'arg', so we simplify + -- to make it all consistent. It's a bit messy. + -- But it isn't a common case. + -- Example of use: #995 + ; return (ApplyToVal { sc_arg = mkCast arg' co1 + , sc_env = arg_se' + , sc_dup = dup' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } } } + + addCoerce co cont + | isReflexiveCo co = return cont -- Having this at the end makes a huge + -- difference in T12227, for some reason + -- See Note [Optimising reflexivity] + | otherwise = return (CastIt co cont) + + fixed_rep :: MCoercionR -> Bool + fixed_rep MRefl = True + fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co + -- Without this check, we can get an argument which does not + -- have a fixed runtime representation. + -- See Note [Representation polymorphism invariants] in GHC.Core + -- test: typecheck/should_run/EtaExpandLevPoly + +simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr + -> SimplM (DupFlag, StaticEnv, OutExpr) +simplArg env dup_flag arg_env arg + | isSimplified dup_flag + = return (dup_flag, arg_env, arg) + | otherwise + = do { let arg_env' = arg_env `setInScopeFromE` env + ; arg' <- simplExpr arg_env' arg + ; return (Simplified, zapSubstEnv arg_env', arg') } + -- Return a StaticEnv that includes the in-scope set from 'env', + -- because arg' may well mention those variables (#20639) + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +simplLam :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont +simplLam env expr cont = simplExprF env expr cont + +simpl_lam :: SimplEnv -> InBndr -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- Type beta-reduction +simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) + = do { tick (BetaReduction bndr) + ; simplLam (extendTvSubst env bndr arg_ty) body cont } + +-- Value beta-reduction +simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_cont = cont, sc_dup = dup }) + | isSimplified dup -- Don't re-simplify if we've simplified it once + -- See Note [Avoiding exponential behaviour] + = do { tick (BetaReduction bndr) + ; completeBindX env bndr arg body cont } + + | otherwise -- See Note [Avoiding exponential behaviour] + = do { tick (BetaReduction bndr) + ; simplNonRecE env bndr (arg, arg_se) body cont } + +-- Discard a non-counting tick on a lambda. This may change the +-- cost attribution slightly (moving the allocation of the +-- lambda elsewhere), but we don't care: optimisation changes +-- cost attribution all the time. +simpl_lam env bndr body (TickIt tickish cont) + | not (tickishCounts tickish) + = simpl_lam env bndr body cont + +-- Not enough args, so there are real lambdas left to put in the result +simpl_lam env bndr body cont + = do { let (inner_bndrs, inner_body) = collectBinders body + ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs) + ; body' <- simplExpr env' inner_body + ; new_lam <- rebuildLam env' bndrs' body' cont + ; rebuild env' new_lam cont } + +------------- +simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- Historically this had a special case for when a lambda-binder +-- could have a stable unfolding; +-- see Historical Note [Case binders and join points] +-- But now it is much simpler! We now only remove unfoldings. +-- See Note [Never put `OtherCon` unfoldings on lambda binders] +simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr) + +simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs + +------------------ +simplNonRecE :: SimplEnv + -> InId -- The binder, always an Id + -- Never a join point + -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> InExpr -- Body of the let/lambda + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- simplNonRecE is used for +-- * non-top-level non-recursive non-join-point lets in expressions +-- * beta reduction +-- +-- simplNonRec env b (rhs, rhs_se) body k +-- = let env in +-- cont< let b = rhs_se(rhs) in body > +-- +-- It deals with strict bindings, via the StrictBind continuation, +-- which may abort the whole process. +-- +-- The RHS may not satisfy the let-can-float invariant yet + +simplNonRecE env bndr (rhs, rhs_se) body cont + = assert (isId bndr && not (isJoinId bndr) ) $ + do { (env1, bndr1) <- simplNonRecBndr env bndr + ; let needs_case_binding = needsCaseBinding (idType bndr1) rhs + -- See Note [Dark corner with representation polymorphism] + ; if | not needs_case_binding + , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se -> + do { tick (PreInlineUnconditionally bndr) + ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ + simplLam env' body cont } + + + -- Deal with strict bindings + -- See Note [Dark corner with representation polymorphism] + | isStrictId bndr1 && seCaseCase env + || needs_case_binding -> + simplExprF (rhs_se `setInScopeFromE` env) rhs + (StrictBind { sc_bndr = bndr, sc_body = body + , sc_env = env, sc_cont = cont, sc_dup = NoDup }) + + -- Deal with lazy bindings + | otherwise -> + do { (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) + ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se + ; (floats2, expr') <- simplLam env3 body cont + ; return (floats1 `addFloats` floats2, expr') } } + +------------------ +simplRecE :: SimplEnv + -> [(InId, InExpr)] + -> InExpr + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- simplRecE is used for +-- * non-top-level recursive lets in expressions +-- Precondition: not a join-point binding +simplRecE env pairs body cont + = do { let bndrs = map fst pairs + ; massert (all (not . isJoinId) bndrs) + ; env1 <- simplRecBndrs env bndrs + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + ; (floats1, env2) <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs + ; (floats2, expr') <- simplExprF env2 body cont + ; return (floats1 `addFloats` floats2, expr') } + +{- Note [Dark corner with representation polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `simplNonRecE`, the call to `needsCaseBinding` or to `isStrictId` will fail +if the binder does not have a fixed runtime representation, e.g. if it is of kind (TYPE r). +So we are careful to call `isStrictId` on the OutId, not the InId, in case we have + ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg) +That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell +if x is lifted or unlifted from that. + +We only get such redexes from the compulsory inlining of a wired-in, +representation-polymorphic function like `rightSection` (see +GHC.Types.Id.Make). Mind you, SimpleOpt should probably have inlined +such compulsory inlinings already, but belt and braces does no harm. + +Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the +Simplifier without first calling SimpleOpt, so anything involving +GHCi or TH and operator sections will fall over if we don't take +care here. + +Note [Avoiding exponential behaviour] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One way in which we can get exponential behaviour is if we simplify a +big expression, and the re-simplify it -- and then this happens in a +deeply-nested way. So we must be jolly careful about re-simplifying +an expression. That is why simplNonRecX does not try +preInlineUnconditionally (unlike simplNonRecE). + +Example: + f BIG, where f has a RULE +Then + * We simplify BIG before trying the rule; but the rule does not fire + * We inline f = \x. x True + * So if we did preInlineUnconditionally we'd re-simplify (BIG True) + +However, if BIG has /not/ already been simplified, we'd /like/ to +simplify BIG True; maybe good things happen. That is why + +* simplLam has + - a case for (isSimplified dup), which goes via simplNonRecX, and + - a case for the un-simplified case, which goes via simplNonRecE + +* We go to some efforts to avoid unnecessarily simplifying ApplyToVal, + in at least two places + - In simplCast/addCoerce, where we check for isReflCo + - In rebuildCall we avoid simplifying arguments before we have to + (see Note [Trying rewrite rules]) + + +************************************************************************ +* * + Join points +* * +********************************************************************* -} + +{- Note [Rules and unfolding for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + simplExpr (join j x = rhs ) cont + ( {- RULE j (p:ps) = blah -} ) + ( {- StableUnfolding j = blah -} ) + (in blah ) + +Then we will push 'cont' into the rhs of 'j'. But we should *also* push +'cont' into the RHS of + * Any RULEs for j, e.g. generated by SpecConstr + * Any stable unfolding for j, e.g. the result of an INLINE pragma + +Simplifying rules and stable-unfoldings happens a bit after +simplifying the right-hand side, so we remember whether or not it +is a join point, and what 'cont' is, in a value of type MaybeJoinCont + +#13900 was caused by forgetting to push 'cont' into the RHS +of a SpecConstr-generated RULE for a join point. +-} + +simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplNonRecJoinPoint env bndr rhs body cont + | assert (isJoinId bndr ) True + , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env + = do { tick (PreInlineUnconditionally bndr) + ; simplExprF env' body cont } + + | otherwise + = wrapJoinCont env cont $ \ env cont -> + do { -- We push join_cont into the join RHS and the body; + -- and wrap wrap_cont around the whole thing + ; let mult = contHoleScaling cont + res_ty = contResultType cont + ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join cont) + ; (floats1, env3) <- simplJoinBind env2 cont bndr bndr2 rhs env + ; (floats2, body') <- simplExprF env3 body cont + ; return (floats1 `addFloats` floats2, body') } + + +------------------ +simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplRecJoinPoint env pairs body cont + = wrapJoinCont env cont $ \ env cont -> + do { let bndrs = map fst pairs + mult = contHoleScaling cont + res_ty = contResultType cont + ; env1 <- simplRecJoinBndrs env bndrs mult res_ty + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + ; (floats1, env2) <- simplRecBind env1 (BC_Join cont) pairs + ; (floats2, body') <- simplExprF env2 body cont + ; return (floats1 `addFloats` floats2, body') } + +-------------------- +wrapJoinCont :: SimplEnv -> SimplCont + -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) + -> SimplM (SimplFloats, OutExpr) +-- Deal with making the continuation duplicable if necessary, +-- and with the no-case-of-case situation. +wrapJoinCont env cont thing_inside + | contIsStop cont -- Common case; no need for fancy footwork + = thing_inside env cont + + | not (seCaseCase env) + -- See Note [Join points with -fno-case-of-case] + = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) + ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 + ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont + ; return (floats2 `addFloats` floats3, expr3) } + + | otherwise + -- Normal case; see Note [Join points and case-of-case] + = do { (floats1, cont') <- mkDupableCont env cont + ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' + ; return (floats1 `addFloats` floats2, result) } + + +-------------------- +trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont +-- Drop outer context from join point invocation (jump) +-- See Note [Join points and case-of-case] + +trimJoinCont _ Nothing cont + = cont -- Not a jump +trimJoinCont var (Just arity) cont + = trim arity cont + where + trim 0 cont@(Stop {}) + = cont + trim 0 cont + = mkBoringStop (contResultType cont) + trim n cont@(ApplyToVal { sc_cont = k }) + = cont { sc_cont = trim (n-1) k } + trim n cont@(ApplyToTy { sc_cont = k }) + = cont { sc_cont = trim (n-1) k } -- join arity counts types! + trim _ cont + = pprPanic "completeCall" $ ppr var $$ ppr cont + + +{- Note [Join points and case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we perform the case-of-case transform (or otherwise push continuations +inward), we want to treat join points specially. Since they're always +tail-called and we want to maintain this invariant, we can do this (for any +evaluation context E): + + E[join j = e + in case ... of + A -> jump j 1 + B -> jump j 2 + C -> f 3] + + --> + + join j = E[e] + in case ... of + A -> jump j 1 + B -> jump j 2 + C -> E[f 3] + +As is evident from the example, there are two components to this behavior: + + 1. When entering the RHS of a join point, copy the context inside. + 2. When a join point is invoked, discard the outer context. + +We need to be very careful here to remain consistent---neither part is +optional! + +We need do make the continuation E duplicable (since we are duplicating it) +with mkDupableCont. + + +Note [Join points with -fno-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Supose case-of-case is switched off, and we are simplifying + + case (join j x = <j-rhs> in + case y of + A -> j 1 + B -> j 2 + C -> e) of <outer-alts> + +Usually, we'd push the outer continuation (case . of <outer-alts>) into +both the RHS and the body of the join point j. But since we aren't doing +case-of-case we may then end up with this totally bogus result + + join x = case <j-rhs> of <outer-alts> in + case (case y of + A -> j 1 + B -> j 2 + C -> e) of <outer-alts> + +This would be OK in the language of the paper, but not in GHC: j is no longer +a join point. We can only do the "push continuation into the RHS of the +join point j" if we also push the continuation right down to the /jumps/ to +j, so that it can evaporate there. If we are doing case-of-case, we'll get to + + join x = case <j-rhs> of <outer-alts> in + case y of + A -> j 1 + B -> j 2 + C -> case e of <outer-alts> + +which is great. + +Bottom line: if case-of-case is off, we must stop pushing the continuation +inwards altogether at any join point. Instead simplify the (join ... in ...) +with a Stop continuation, and wrap the original continuation around the +outside. Surprisingly tricky! + + +************************************************************************ +* * + Variables +* * +************************************************************************ +-} + +simplVar :: SimplEnv -> InVar -> SimplM OutExpr +-- Look up an InVar in the environment +simplVar env var + -- Why $! ? See Note [Bangs in the Simplifier] + | isTyVar var = return $! Type $! (substTyVar env var) + | isCoVar var = return $! Coercion $! (substCoVar env var) + | otherwise + = case substId env var of + ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids + in simplExpr env' e + DoneId var1 -> return (Var var1) + DoneEx e _ -> return e + +simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) +simplIdF env var cont + = case substId env var of + ContEx tvs cvs ids e -> + let env' = setSubstEnv env tvs cvs ids + in simplExprF env' e cont + -- Don't trim; haven't already simplified e, + -- so the cont is not embodied in e + + DoneId var1 -> do + logger <- getLogger + let cont' = trimJoinCont var (isJoinId_maybe var1) cont + completeCall logger env var1 cont' + + DoneEx e mb_join -> + let env' = zapSubstEnv env + cont' = trimJoinCont var mb_join cont + in simplExprF env' e cont' + -- Note [zapSubstEnv] + -- ~~~~~~~~~~~~~~~~~~ + -- The template is already simplified, so don't re-substitute. + -- This is VITAL. Consider + -- let x = e in + -- let y = \z -> ...x... in + -- \ x -> ...y... + -- We'll clone the inner \x, adding x->x' in the id_subst + -- Then when we inline y, we must *not* replace x by x' in + -- the inlined copy!! + +--------------------------------------------------------- +-- Dealing with a call site + +completeCall :: Logger -> SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) +completeCall logger env var cont + | Just expr <- callSiteInline logger uf_opts case_depth var active_unf + lone_variable arg_infos interesting_cont + -- Inline the variable's RHS + = do { checkedTick (UnfoldingDone var) + ; dump_inline expr cont + ; let env1 = zapSubstEnv env + ; simplExprF env1 expr cont } + + | otherwise + -- Don't inline; instead rebuild the call + = do { rule_base <- getSimplRules + ; let rules = getRules rule_base var + info = mkArgInfo env var rules + n_val_args call_cont + ; rebuildCall env info cont } + + where + uf_opts = seUnfoldingOpts env + case_depth = seCaseDepth env + (lone_variable, arg_infos, call_cont) = contArgs cont + n_val_args = length arg_infos + interesting_cont = interestingCallContext env call_cont + active_unf = activeUnfolding (seMode env) var + + log_inlining doc + = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) + Opt_D_dump_inlinings + "" FormatText doc + + dump_inline unfolding cont + | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return () + | not (logHasDumpFlag logger Opt_D_verbose_core2core) + = when (isExternalName (idName var)) $ + log_inlining $ + sep [text "Inlining done:", nest 4 (ppr var)] + | otherwise + = log_inlining $ + sep [text "Inlining done: " <> ppr var, + nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr cont])] + +rebuildCall :: SimplEnv + -> ArgInfo + -> SimplCont + -> SimplM (SimplFloats, OutExpr) +-- We decided not to inline, so +-- - simplify the arguments +-- - try rewrite rules +-- - and rebuild + +---------- Bottoming applications -------------- +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont + -- When we run out of strictness args, it means + -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo + -- Then we want to discard the entire strict continuation. E.g. + -- * case (error "hello") of { ... } + -- * (error "Hello") arg + -- * f (error "Hello") where f is strict + -- etc + -- Then, especially in the first of these cases, we'd like to discard + -- the continuation, leaving just the bottoming expression. But the + -- type might not be right, so we may have to add a coerce. + | not (contIsTrivial cont) -- Only do this if there is a non-trivial + -- continuation to discard, else we do it + -- again and again! + = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] + return (emptyFloats env, castBottomExpr res cont_ty) + where + res = argInfoExpr fun rev_args + cont_ty = contResultType cont + +---------- Try rewrite RULES -------------- +-- See Note [Trying rewrite rules] +rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args + , ai_rules = Just (nr_wanted, rules) }) cont + | nr_wanted == 0 || no_more_args + , let info' = info { ai_rules = Nothing } + = -- We've accumulated a simplified call in <fun,rev_args> + -- so try rewrite rules; see Note [RULES apply to simplified arguments] + -- See also Note [Rules for recursive functions] + do { mb_match <- tryRules env rules fun (reverse rev_args) cont + ; case mb_match of + Just (env', rhs, cont') -> simplExprF env' rhs cont' + Nothing -> rebuildCall env info' cont } + where + no_more_args = case cont of + ApplyToTy {} -> False + ApplyToVal {} -> False + _ -> True + + +---------- Simplify applications and casts -------------- +rebuildCall env info (CastIt co cont) + = rebuildCall env (addCastTo info co) cont + +rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }) + = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont + +---------- The runRW# rule. Do this after absorbing all arguments ------ +-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep. +-- +-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o +-- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ]) +rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args }) + (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_cont = cont, sc_hole_ty = fun_ty }) + | fun_id `hasKey` runRWKey + , not (contIsStop cont) -- Don't fiddle around if the continuation is boring + , [ TyArg {}, TyArg {} ] <- rev_args + = do { s <- newId (fsLit "s") Many realWorldStatePrimTy + ; let (m,_,_) = splitFunTy fun_ty + env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s] + ty' = contResultType cont + cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s + , sc_env = env', sc_cont = cont + , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } + -- cont' applies to s, then K + ; body' <- simplExprC env' arg cont' + ; let arg' = Lam s body' + rr' = getRuntimeRep ty' + call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] + ; return (emptyFloats env, call') } + +rebuildCall env fun_info + (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup_flag, sc_hole_ty = fun_ty + , sc_cont = cont }) + -- Argument is already simplified + | isSimplified dup_flag -- See Note [Avoid redundant simplification] + = rebuildCall env (addValArgTo fun_info arg fun_ty) cont + + -- Strict arguments + | isStrictArgInfo fun_info + , seCaseCase env + = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ + simplExprF (arg_se `setInScopeFromE` env) arg + (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty + , sc_dup = Simplified + , sc_cont = cont }) + -- Note [Shadowing] + + -- Lazy arguments + | otherwise + -- DO NOT float anything outside, hence simplExprC + -- There is no benefit (unlike in a let-binding), and we'd + -- have to be very careful about bogus strictness through + -- floating a demanded let. + = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg + (mkLazyArgStop arg_ty fun_info) + ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } + where + arg_ty = funArgTy fun_ty + + +---------- No further useful info, revert to generic rebuild ------------ +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont + = rebuild env (argInfoExpr fun rev_args) cont + +{- Note [Trying rewrite rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet +simplified. We want to simplify enough arguments to allow the rules +to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone +is sufficient. Example: class ops + (+) dNumInt e2 e3 +If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the +latter's strictness when simplifying e2, e3. Moreover, suppose we have + RULE f Int = \x. x True + +Then given (f Int e1) we rewrite to + (\x. x True) e1 +without simplifying e1. Now we can inline x into its unique call site, +and absorb the True into it all in the same pass. If we simplified +e1 first, we couldn't do that; see Note [Avoiding exponential behaviour]. + +So we try to apply rules if either + (a) no_more_args: we've run out of argument that the rules can "see" + (b) nr_wanted: none of the rules wants any more arguments + + +Note [RULES apply to simplified arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very desirable to try RULES once the arguments have been simplified, because +doing so ensures that rule cascades work in one pass. Consider + {-# RULES g (h x) = k x + f (k x) = x #-} + ...f (g (h x))... +Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If +we match f's rules against the un-simplified RHS, it won't match. This +makes a particularly big difference when superclass selectors are involved: + op ($p1 ($p2 (df d))) +We want all this to unravel in one sweep. + +Note [Avoid redundant simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because RULES apply to simplified arguments, there's a danger of repeatedly +simplifying already-simplified arguments. An important example is that of + (>>=) d e1 e2 +Here e1, e2 are simplified before the rule is applied, but don't really +participate in the rule firing. So we mark them as Simplified to avoid +re-simplifying them. + +Note [Shadowing] +~~~~~~~~~~~~~~~~ +This part of the simplifier may break the no-shadowing invariant +Consider + f (...(\a -> e)...) (case y of (a,b) -> e') +where f is strict in its second arg +If we simplify the innermost one first we get (...(\a -> e)...) +Simplifying the second arg makes us float the case out, so we end up with + case y of (a,b) -> f (...(\a -> e)...) e' +So the output does not have the no-shadowing invariant. However, there is +no danger of getting name-capture, because when the first arg was simplified +we used an in-scope set that at least mentioned all the variables free in its +static environment, and that is enough. + +We can't just do innermost first, or we'd end up with a dual problem: + case x of (a,b) -> f e (...(\a -> e')...) + +I spent hours trying to recover the no-shadowing invariant, but I just could +not think of an elegant way to do it. The simplifier is already knee-deep in +continuations. We have to keep the right in-scope set around; AND we have +to get the effect that finding (error "foo") in a strict arg position will +discard the entire application and replace it with (error "foo"). Getting +all this at once is TOO HARD! + + +************************************************************************ +* * + Rewrite rules +* * +************************************************************************ +-} + +tryRules :: SimplEnv -> [CoreRule] + -> Id -> [ArgSpec] + -> SimplCont + -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) + +tryRules env rules fn args call_cont + | null rules + = return Nothing + +{- Disabled until we fix #8326 + | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#] + , [_type_arg, val_arg] <- args + , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont + , isDeadBinder bndr + = do { let enum_to_tag :: CoreAlt -> CoreAlt + -- Takes K -> e into tagK# -> e + -- where tagK# is the tag of constructor K + enum_to_tag (DataAlt con, [], rhs) + = assert (isEnumerationTyCon (dataConTyCon con) ) + (LitAlt tag, [], rhs) + where + tag = mkLitInt (sePlatform env) (toInteger (dataConTag con - fIRST_TAG)) + enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt) + + new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts + new_bndr = setIdType bndr intPrimTy + -- The binder is dead, but should have the right type + ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } +-} + + | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env) + (activeRule (seMode env)) fn + (argInfoAppArgs args) rules + -- Fire a rule for the function + = do { logger <- getLogger + ; checkedTick (RuleFired (ruleName rule)) + ; let cont' = pushSimplifiedArgs zapped_env + (drop (ruleArity rule) args) + call_cont + -- (ruleArity rule) says how + -- many args the rule consumed + + occ_anald_rhs = occurAnalyseExpr rule_rhs + -- See Note [Occurrence-analyse after rule firing] + ; dump logger rule rule_rhs + ; return (Just (zapped_env, occ_anald_rhs, cont')) } + -- The occ_anald_rhs and cont' are all Out things + -- hence zapping the environment + + | otherwise -- No rule fires + = do { logger <- getLogger + ; nodump logger -- This ensures that an empty file is written + ; return Nothing } + + where + ropts = seRuleOpts env + zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] + + printRuleModule rule + = parens (maybe (text "BUILTIN") + (pprModuleName . moduleName) + (ruleModule rule)) + + dump logger rule rule_rhs + | logHasDumpFlag logger Opt_D_dump_rule_rewrites + = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat + [ text "Rule:" <+> ftext (ruleName rule) + , text "Module:" <+> printRuleModule rule + , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) + , text "After: " <+> hang (pprCoreExpr rule_rhs) 2 + (sep $ map ppr $ drop (ruleArity rule) args) + , text "Cont: " <+> ppr call_cont ] + + | logHasDumpFlag logger Opt_D_dump_rule_firings + = log_rule Opt_D_dump_rule_firings "Rule fired:" $ + ftext (ruleName rule) + <+> printRuleModule rule + + | otherwise + = return () + + nodump logger + | logHasDumpFlag logger Opt_D_dump_rule_rewrites + = liftIO $ + touchDumpFile logger Opt_D_dump_rule_rewrites + + | logHasDumpFlag logger Opt_D_dump_rule_firings + = liftIO $ + touchDumpFile logger Opt_D_dump_rule_firings + + | otherwise + = return () + + log_rule flag hdr details + = do + { logger <- getLogger + ; liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText + $ sep [text hdr, nest 4 details] + } + +trySeqRules :: SimplEnv + -> OutExpr -> InExpr -- Scrutinee and RHS + -> SimplCont + -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) +-- See Note [User-defined RULES for seq] +trySeqRules in_env scrut rhs cont + = do { rule_base <- getSimplRules + ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont } + where + no_cast_scrut = drop_casts scrut + scrut_ty = exprType no_cast_scrut + seq_id_ty = idType seqId -- forall r a (b::TYPE r). a -> b -> b + res1_ty = piResultTy seq_id_ty rhs_rep -- forall a (b::TYPE rhs_rep). a -> b -> b + res2_ty = piResultTy res1_ty scrut_ty -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b + res3_ty = piResultTy res2_ty rhs_ty -- scrut_ty -> rhs_ty -> rhs_ty + res4_ty = funResultTy res3_ty -- rhs_ty -> rhs_ty + rhs_ty = substTy in_env (exprType rhs) + rhs_rep = getRuntimeRep rhs_ty + out_args = [ TyArg { as_arg_ty = rhs_rep + , as_hole_ty = seq_id_ty } + , TyArg { as_arg_ty = scrut_ty + , as_hole_ty = res1_ty } + , TyArg { as_arg_ty = rhs_ty + , as_hole_ty = res2_ty } + , ValArg { as_arg = no_cast_scrut + , as_dmd = seqDmd + , as_hole_ty = res3_ty } ] + rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs + , sc_env = in_env, sc_cont = cont + , sc_hole_ty = res4_ty } + + -- Lazily evaluated, so we don't do most of this + + drop_casts (Cast e _) = drop_casts e + drop_casts e = e + +{- Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given + case (scrut |> co) of _ -> rhs +look for rules that match the expression + seq @t1 @t2 scrut +where scrut :: t1 + rhs :: t2 + +If you find a match, rewrite it, and apply to 'rhs'. + +Notice that we can simply drop casts on the fly here, which +makes it more likely that a rule will match. + +See Note [User-defined RULES for seq] in GHC.Types.Id.Make. + +Note [Occurrence-analyse after rule firing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After firing a rule, we occurrence-analyse the instantiated RHS before +simplifying it. Usually this doesn't make much difference, but it can +be huge. Here's an example (simplCore/should_compile/T7785) + + map f (map f (map f xs) + += -- Use build/fold form of map, twice + map f (build (\cn. foldr (mapFB c f) n + (build (\cn. foldr (mapFB c f) n xs)))) + += -- Apply fold/build rule + map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n)) + += -- Beta-reduce + -- Alas we have no occurrence-analysed, so we don't know + -- that c is used exactly once + map f (build (\cn. let c1 = mapFB c f in + foldr (mapFB c1 f) n xs)) + += -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g) + -- We can do this because (mapFB c n) is a PAP and hence expandable + map f (build (\cn. let c1 = mapFB c n in + foldr (mapFB c (f.f)) n x)) + +This is not too bad. But now do the same with the outer map, and +we get another use of mapFB, and t can interact with /both/ remaining +mapFB calls in the above expression. This is stupid because actually +that 'c1' binding is dead. The outer map introduces another c2. If +there is a deep stack of maps we get lots of dead bindings, and lots +of redundant work as we repeatedly simplify the result of firing rules. + +The easy thing to do is simply to occurrence analyse the result of +the rule firing. Note that this occ-anals not only the RHS of the +rule, but also the function arguments, which by now are OutExprs. +E.g. + RULE f (g x) = x+1 + +Call f (g BIG) --> (\x. x+1) BIG + +The rule binders are lambda-bound and applied to the OutExpr arguments +(here BIG) which lack all internal occurrence info. + +Is this inefficient? Not really: we are about to walk over the result +of the rule firing to simplify it, so occurrence analysis is at most +a constant factor. + +Possible improvement: occ-anal the rules when putting them in the +database; and in the simplifier just occ-anal the OutExpr arguments. +But that's more complicated and the rule RHS is usually tiny; so I'm +just doing the simple thing. + +Historical note: previously we did occ-anal the rules in Rule.hs, +but failed to occ-anal the OutExpr arguments, which led to the +nasty performance problem described above. + + +Note [Optimising tagToEnum#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an enumeration data type: + + data Foo = A | B | C + +Then we want to transform + + case tagToEnum# x of ==> case x of + A -> e1 DEFAULT -> e1 + B -> e2 1# -> e2 + C -> e3 2# -> e3 + +thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT +alternative we retain it (remember it comes first). If not the case must +be exhaustive, and we reflect that in the transformed version by adding +a DEFAULT. Otherwise Lint complains that the new case is not exhaustive. +See #8317. + +Note [Rules for recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that we shouldn't apply rules for a loop breaker: +doing so might give rise to an infinite loop, because a RULE is +rather like an extra equation for the function: + RULE: f (g x) y = x+y + Eqn: f a y = a-y + +But it's too drastic to disable rules for loop breakers. +Even the foldr/build rule would be disabled, because foldr +is recursive, and hence a loop breaker: + foldr k z (build g) = g k z +So it's up to the programmer: rules can cause divergence + + +************************************************************************ +* * + Rebuilding a case expression +* * +************************************************************************ + +Note [Case elimination] +~~~~~~~~~~~~~~~~~~~~~~~ +The case-elimination transformation discards redundant case expressions. +Start with a simple situation: + + case x# of ===> let y# = x# in e + y# -> e + +(when x#, y# are of primitive type, of course). We can't (in general) +do this for algebraic cases, because we might turn bottom into +non-bottom! + +The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise +this idea to look for a case where we're scrutinising a variable, and we know +that only the default case can match. For example: + + case x of + 0# -> ... + DEFAULT -> ...(case x of + 0# -> ... + DEFAULT -> ...) ... + +Here the inner case is first trimmed to have only one alternative, the +DEFAULT, after which it's an instance of the previous case. This +really only shows up in eliminating error-checking code. + +Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs. So + + case e of ===> case e of DEFAULT -> r + True -> r + False -> r + +Now again the case may be eliminated by the CaseElim transformation. +This includes things like (==# a# b#)::Bool so that we simplify + case ==# a# b# of { True -> x; False -> x } +to just + x +This particular example shows up in default methods for +comparison operations (e.g. in (>=) for Int.Int32) + +Note [Case to let transformation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a case over a lifted type has a single alternative, and is being +used as a strict 'let' (all isDeadBinder bndrs), we may want to do +this transformation: + + case e of r ===> let r = e in ...r... + _ -> ...r... + +We treat the unlifted and lifted cases separately: + +* Unlifted case: 'e' satisfies exprOkForSpeculation + (ok-for-spec is needed to satisfy the let-can-float invariant). + This turns case a +# b of r -> ...r... + into let r = a +# b in ...r... + and thence .....(a +# b).... + + However, if we have + case indexArray# a i of r -> ...r... + we might like to do the same, and inline the (indexArray# a i). + But indexArray# is not okForSpeculation, so we don't build a let + in rebuildCase (lest it get floated *out*), so the inlining doesn't + happen either. Annoying. + +* Lifted case: we need to be sure that the expression is already + evaluated (exprIsHNF). If it's not already evaluated + - we risk losing exceptions, divergence or + user-specified thunk-forcing + - even if 'e' is guaranteed to converge, we don't want to + create a thunk (call by need) instead of evaluating it + right away (call by value) + + However, we can turn the case into a /strict/ let if the 'r' is + used strictly in the body. Then we won't lose divergence; and + we won't build a thunk because the let is strict. + See also Note [Case-to-let for strictly-used binders] + +Note [Case-to-let for strictly-used binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have this: + case <scrut> of r { _ -> ..r.. } + +where 'r' is used strictly in (..r..), we can safely transform to + let r = <scrut> in ...r... + +This is a Good Thing, because 'r' might be dead (if the body just +calls error), or might be used just once (in which case it can be +inlined); or we might be able to float the let-binding up or down. +E.g. #15631 has an example. + +Note that this can change the error behaviour. For example, we might +transform + case x of { _ -> error "bad" } + --> error "bad" +which is might be puzzling if 'x' currently lambda-bound, but later gets +let-bound to (error "good"). + +Nevertheless, the paper "A semantics for imprecise exceptions" allows +this transformation. If you want to fix the evaluation order, use +'pseq'. See #8900 for an example where the loss of this +transformation bit us in practice. + +See also Note [Empty case alternatives] in GHC.Core. + +Historical notes + +There have been various earlier versions of this patch: + +* By Sept 18 the code looked like this: + || scrut_is_demanded_var scrut + + scrut_is_demanded_var :: CoreExpr -> Bool + scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s + scrut_is_demanded_var (Var _) = isStrUsedDmd (idDemandInfo case_bndr) + scrut_is_demanded_var _ = False + + This only fired if the scrutinee was a /variable/, which seems + an unnecessary restriction. So in #15631 I relaxed it to allow + arbitrary scrutinees. Less code, less to explain -- but the change + had 0.00% effect on nofib. + +* Previously, in Jan 13 the code looked like this: + || case_bndr_evald_next rhs + + case_bndr_evald_next :: CoreExpr -> Bool + -- See Note [Case binder next] + case_bndr_evald_next (Var v) = v == case_bndr + case_bndr_evald_next (Cast e _) = case_bndr_evald_next e + case_bndr_evald_next (App e _) = case_bndr_evald_next e + case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e + case_bndr_evald_next _ = False + + This patch was part of fixing #7542. See also + Note [Eta reduction soundness], criterion (E) in GHC.Core.Utils.) + + +Further notes about case elimination +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: test :: Integer -> IO () + test = print + +Turns out that this compiles to: + Print.test + = \ eta :: Integer + eta1 :: Void# -> + case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> + case hPutStr stdout + (PrelNum.jtos eta ($w[] @ Char)) + eta1 + of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} + +Notice the strange '<' which has no effect at all. This is a funny one. +It started like this: + +f x y = if x < 0 then jtos x + else if y==0 then "" else jtos x + +At a particular call site we have (f v 1). So we inline to get + + if v < 0 then jtos x + else if 1==0 then "" else jtos x + +Now simplify the 1==0 conditional: + + if v<0 then jtos v else jtos v + +Now common-up the two branches of the case: + + case (v<0) of DEFAULT -> jtos v + +Why don't we drop the case? Because it's strict in v. It's technically +wrong to drop even unnecessary evaluations, and in practice they +may be a result of 'seq' so we *definitely* don't want to drop those. +I don't really know how to improve this situation. + + +Note [FloatBinds from constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have FloatBinds coming from the constructor wrapper +(as in Note [exprIsConApp_maybe on data constructors with wrappers]), +we cannot float past them. We'd need to float the FloatBind +together with the simplify floats, unfortunately the +simplifier doesn't have case-floats. The simplest thing we can +do is to wrap all the floats here. The next iteration of the +simplifier will take care of all these cases and lets. + +Given data T = MkT !Bool, this allows us to simplify +case $WMkT b of { MkT x -> f x } +to +case b of { b' -> f b' }. + +We could try and be more clever (like maybe wfloats only contain +let binders, so we could float them). But the need for the +extra complication is not clear. + +Note [Do not duplicate constructor applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#20125) + let x = (a,b) + in ...(case x of x' -> blah)...x...x... + +We want that `case` to vanish (since `x` is bound to a data con) leaving + let x = (a,b) + in ...(let x'=x in blah)...x..x... + +In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`, +since is bound to (a,b). But in eliminating the case, if the scrutinee +is trivial, we want to bind the case-binder to the scrutinee, /not/ to +the constructor application. Hence the case_bndr_rhs in rebuildCase. + +This applies equally to a non-DEFAULT case alternative, say + let x = (a,b) in ...(case x of x' { (p,q) -> blah })... +This variant is handled by bind_case_bndr in knownCon. + +We want to bind x' to x, and not to a duplicated (a,b)). +-} + +--------------------------------------------------------- +-- Eliminate the case if possible + +rebuildCase, reallyRebuildCase + :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Alternatives (increasing order) + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-------------------------------------------------- +-- 1. Eliminate the case if there's a known constructor +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts cont + | Lit lit <- scrut -- No need for same treatment as constructors + -- because literals are inlined more vigorously + , not (litIsLifted lit) + = do { tick (KnownBranch case_bndr) + ; case findAlt (LitAlt lit) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs } + + | Just (in_scope', wfloats, con, ty_args, other_args) + <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut + -- Works when the scrutinee is a variable with a known unfolding + -- as well as when it's an explicit constructor application + , let env0 = setInScopeSet env in_scope' + = do { tick (KnownBranch case_bndr) + ; let scaled_wfloats = map scale_float wfloats + -- case_bndr_unf: see Note [Do not duplicate constructor applications] + case_bndr_rhs | exprIsTrivial scrut = scrut + | otherwise = con_app + con_app = Var (dataConWorkId con) `mkTyApps` ty_args + `mkApps` other_args + ; case findAlt (DataAlt con) alts of + Nothing -> missingAlt env0 case_bndr alts cont + Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs + Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args + other_args case_bndr bs rhs cont + } + where + simple_rhs env wfloats case_bndr_rhs bs rhs = + assert (null bs) $ + do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs + -- scrut is a constructor application, + -- hence satisfies let-can-float invariant + ; (floats2, expr') <- simplExprF env' rhs cont + ; case wfloats of + [] -> return (floats1 `addFloats` floats2, expr') + _ -> return + -- See Note [FloatBinds from constructor wrappers] + ( emptyFloats env, + GHC.Core.Make.wrapFloats wfloats $ + wrapFloats (floats1 `addFloats` floats2) expr' )} + + -- This scales case floats by the multiplicity of the continuation hole (see + -- Note [Scaling in case-of-case]). Let floats are _not_ scaled, because + -- they are aliases anyway. + scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) = + let + scale_id id = scaleVarBy holeScaling id + in + GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) + scale_float f = f + + holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr + -- We are in the following situation + -- case[p] case[q] u of { D x -> C v } of { C x -> w } + -- And we are producing case[??] u of { D x -> w[x\v]} + -- + -- What should the multiplicity `??` be? In order to preserve the usage of + -- variables in `u`, it needs to be `pq`. + -- + -- As an illustration, consider the following + -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) } + -- Where C :: A %1 -> T is linear + -- If we were to produce a case[1], like the inner case, we would get + -- case[1] of { C x -> (x, x) } + -- Which is ill-typed with respect to linearity. So it needs to be a + -- case[Many]. + +-------------------------------------------------- +-- 2. Eliminate the case if scrutinee is evaluated +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont + -- See if we can get rid of the case altogether + -- See Note [Case elimination] + -- mkCase made sure that if all the alternatives are equal, + -- then there is now only one (DEFAULT) rhs + + -- 2a. Dropping the case altogether, if + -- a) it binds nothing (so it's really just a 'seq') + -- b) evaluating the scrutinee has no side effects + | is_plain_seq + , exprOkForSideEffects scrut + -- The entire case is dead, so we can drop it + -- if the scrutinee converges without having imperative + -- side effects or raising a Haskell exception + -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps + = simplExprF env rhs cont + + -- 2b. Turn the case into a let, if + -- a) it binds only the case-binder + -- b) unlifted case: the scrutinee is ok-for-speculation + -- lifted case: the scrutinee is in HNF (or will later be demanded) + -- See Note [Case to let transformation] + | all_dead_bndrs + , doCaseToLet scrut case_bndr + = do { tick (CaseElim case_bndr) + ; (floats1, env') <- simplNonRecX env case_bndr scrut + ; (floats2, expr') <- simplExprF env' rhs cont + ; return (floats1 `addFloats` floats2, expr') } + + -- 2c. Try the seq rules if + -- a) it binds only the case binder + -- b) a rule for seq applies + -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make + | is_plain_seq + = do { mb_rule <- trySeqRules env scrut rhs cont + ; case mb_rule of + Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' + Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + where + all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] + is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect + +rebuildCase env scrut case_bndr alts cont + = reallyRebuildCase env scrut case_bndr alts cont + + +doCaseToLet :: OutExpr -- Scrutinee + -> InId -- Case binder + -> Bool +-- The situation is case scrut of b { DEFAULT -> body } +-- Can we transform thus? let { b = scrut } in body +doCaseToLet scrut case_bndr + | isTyCoVar case_bndr -- Respect GHC.Core + = isTyCoArg scrut -- Note [Core type and coercion invariant] + + | isUnliftedType (exprType scrut) + -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase). + -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr' + -- (which is an 'InId'): see Note [Dark corner with representation polymorphism]. + -- Using `exprType` is typically cheap becuase `scrut` is typically a variable. + -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts + -- the brain more. Consider that if this test ever turns out to be a perf + -- problem (which seems unlikely). + = exprOkForSpeculation scrut + + | otherwise -- Scrut has a lifted type + = exprIsHNF scrut + || isStrUsedDmd (idDemandInfo case_bndr) + -- See Note [Case-to-let for strictly-used binders] + +-------------------------------------------------- +-- 3. Catch-all case +-------------------------------------------------- + +reallyRebuildCase env scrut case_bndr alts cont + | not (seCaseCase env) + = do { case_expr <- simplAlts env scrut case_bndr alts + (mkBoringStop (contHoleType cont)) + ; rebuild env case_expr cont } + + | otherwise + = do { (floats, env', cont') <- mkDupableCaseCont env alts cont + ; case_expr <- simplAlts env' scrut + (scaleIdBy holeScaling case_bndr) + (scaleAltsBy holeScaling alts) + cont' + ; return (floats, case_expr) } + where + holeScaling = contHoleScaling cont + -- Note [Scaling in case-of-case] + +{- +simplCaseBinder checks whether the scrutinee is a variable, v. If so, +try to eliminate uses of v in the RHSs in favour of case_bndr; that +way, there's a chance that v will now only be used once, and hence +inlined. + +Historical note: we use to do the "case binder swap" in the Simplifier +so there were additional complications if the scrutinee was a variable. +Now the binder-swap stuff is done in the occurrence analyser; see +"GHC.Core.Opt.OccurAnal" Note [Binder swap]. + +Note [knownCon occ info] +~~~~~~~~~~~~~~~~~~~~~~~~ +If the case binder is not dead, then neither are the pattern bound +variables: + case <any> of x { (a,b) -> + case x of { (p,q) -> p } } +Here (a,b) both look dead, but come alive after the inner case is eliminated. +The point is that we bring into the envt a binding + let x = (a,b) +after the outer case, and that makes (a,b) alive. At least we do unless +the case binder is guaranteed dead. + +Note [Case alternative occ info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are simply reconstructing a case (the common case), we always +zap the occurrence info on the binders in the alternatives. Even +if the case binder is dead, the scrutinee is usually a variable, and *that* +can bring the case-alternative binders back to life. +See Note [Add unfolding for scrutinee] + +Note [Improving seq] +~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: * -> * + type instance F Int = Int + +We'd like to transform + case e of (x :: F Int) { DEFAULT -> rhs } +===> + case e `cast` co of (x'::Int) + I# x# -> let x = x' `cast` sym co + in rhs + +so that 'rhs' can take advantage of the form of x'. Notice that Note +[Case of cast] (in OccurAnal) may then apply to the result. + +We'd also like to eliminate empty types (#13468). So if + + data Void + type instance F Bool = Void + +then we'd like to transform + case (x :: F Bool) of { _ -> error "urk" } +===> + case (x |> co) of (x' :: Void) of {} + +Nota Bene: we used to have a built-in rule for 'seq' that dropped +casts, so that + case (x |> co) of { _ -> blah } +dropped the cast; in order to improve the chances of trySeqRules +firing. But that works in the /opposite/ direction to Note [Improving +seq] so there's a danger of flip/flopping. Better to make trySeqRules +insensitive to the cast, which is now is. + +The need for [Improving seq] showed up in Roman's experiments. Example: + foo :: F Int -> Int -> Int + foo t n = t `seq` bar n + where + bar 0 = 0 + bar n = bar (n - case t of TI i -> i) +Here we'd like to avoid repeated evaluating t inside the loop, by +taking advantage of the `seq`. + +At one point I did transformation in LiberateCase, but it's more +robust here. (Otherwise, there's a danger that we'll simply drop the +'seq' altogether, before LiberateCase gets to see it.) + +Note [Scaling in case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When two cases commute, if done naively, the multiplicities will be wrong: + + case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many] + { (z[Many], t[Many]) -> z + } + +The multiplicities here, are correct, but if I perform a case of case: + + case u of w[1] + { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } + } + +This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and +`y` must have multiplicities `Many` not `1`! The correct solution is to make +all the `1`-s be `Many`-s instead: + + case u of w[Many] + { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } + } + +In general, when commuting two cases, the rule has to be: + + case (case … of x[p] {…}) of y[q] { … } + ===> case … of x[p*q] { … case … of y[q] { … } } + +This is materialised, in the simplifier, by the fact that every time we simplify +case alternatives with a continuation (the surrounded case (or more!)), we must +scale the entire case we are simplifying, by a scaling factor which can be +computed in the continuation (with function `contHoleScaling`). +-} + +simplAlts :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Non-empty + -> SimplCont + -> SimplM OutExpr -- Returns the complete simplified case expression + +simplAlts env0 scrut case_bndr alts cont' + = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr + , text "cont':" <+> ppr cont' + , text "in_scope" <+> ppr (seInScope env0) ]) + ; (env1, case_bndr1) <- simplBinder env0 case_bndr + ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding + env2 = modifyInScope env1 case_bndr2 + -- See Note [Case binder evaluated-ness] + fam_envs = seFamEnvs env0 + + ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut + case_bndr case_bndr2 alts + + ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts + -- NB: it's possible that the returned in_alts is empty: this is handled + -- by the caller (rebuildCase) in the missingAlt function + + ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts +-- ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return () + + ; let alts_ty' = contResultType cont' + -- See Note [Avoiding space leaks in OutType] + ; seqType alts_ty' `seq` + mkCase (seMode env0) scrut' case_bndr' alts_ty' alts' } + + +------------------------------------ +improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv + -> OutExpr -> InId -> OutId -> [InAlt] + -> SimplM (SimplEnv, OutExpr, OutId) +-- Note [Improving seq] +improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _] + | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) + = do { case_bndr2 <- newId (fsLit "nt") Many ty2 + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing + env2 = extendIdSubst env case_bndr rhs + ; return (env2, scrut `Cast` co, case_bndr2) } + +improveSeq _ env scrut _ case_bndr1 _ + = return (env, scrut, case_bndr1) + + +------------------------------------ +simplAlt :: SimplEnv + -> Maybe OutExpr -- The scrutinee + -> [AltCon] -- These constructors can't be present when + -- matching the DEFAULT alternative + -> OutId -- The case binder + -> SimplCont + -> InAlt + -> SimplM OutAlt + +simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs) + = assert (null bndrs) $ + do { let env' = addBinderUnfolding env case_bndr' + (mkOtherCon imposs_deflt_cons) + -- Record the constructors that the case-binder *can't* be. + ; rhs' <- simplExprC env' rhs cont' + ; return (Alt DEFAULT [] rhs') } + +simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs) + = assert (null bndrs) $ + do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) + ; rhs' <- simplExprC env' rhs cont' + ; return (Alt (LitAlt lit) [] rhs') } + +simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs) + = do { -- See Note [Adding evaluatedness info to pattern-bound variables] + let vs_with_evals = addEvals scrut' con vs + ; (env', vs') <- simplBinders env vs_with_evals + + -- Bind the case-binder to (con args) + ; let inst_tys' = tyConAppArgs (idType case_bndr') + con_app :: OutExpr + con_app = mkConApp2 con inst_tys' vs' + + ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app + ; rhs' <- simplExprC env'' rhs cont' + ; return (Alt (DataAlt con) vs' rhs') } + +{- Note [Adding evaluatedness info to pattern-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +addEvals records the evaluated-ness of the bound variables of +a case pattern. This is *important*. Consider + + data T = T !Int !Int + + case x of { T a b -> T (a+1) b } + +We really must record that b is already evaluated so that we don't +go and re-evaluate it when constructing the result. +See Note [Data-con worker strictness] in GHC.Core.DataCon + +NB: simplLamBndrs preserves this eval info + +In addition to handling data constructor fields with !s, addEvals +also records the fact that the result of seq# is always in WHNF. +See Note [seq# magic] in GHC.Core.Opt.ConstantFold. Example (#15226): + + case seq# v s of + (# s', v' #) -> E + +we want the compiler to be aware that v' is in WHNF in E. + +Open problem: we don't record that v itself is in WHNF (and we can't +do it here). The right thing is to do some kind of binder-swap; +see #15226 for discussion. +-} + +addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id] +-- See Note [Adding evaluatedness info to pattern-bound variables] +addEvals scrut con vs + -- Deal with seq# applications + | Just scr <- scrut + , isUnboxedTupleDataCon con + , [s,x] <- vs + -- Use stripNArgs rather than collectArgsTicks to avoid building + -- a list of arguments only to throw it away immediately. + , Just (Var f) <- stripNArgs 4 scr + , Just SeqOp <- isPrimOpId_maybe f + , let x' = zapIdOccInfoAndSetEvald MarkedStrict x + = [s, x'] + + -- Deal with banged datacon fields +addEvals _scrut con vs = go vs the_strs + where + the_strs = dataConRepStrictness con + + go [] [] = [] + go (v:vs') strs | isTyVar v = v : go vs' strs + go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs + go _ _ = pprPanic "Simplify.addEvals" + (ppr con $$ + ppr vs $$ + ppr_with_length (map strdisp the_strs) $$ + ppr_with_length (dataConRepArgTys con) $$ + ppr_with_length (dataConRepStrictness con)) + where + ppr_with_length list + = ppr list <+> parens (text "length =" <+> ppr (length list)) + strdisp MarkedStrict = text "MarkedStrict" + strdisp NotMarkedStrict = text "NotMarkedStrict" + +zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id +zapIdOccInfoAndSetEvald str v = + setCaseBndrEvald str $ -- Add eval'dness info + zapIdOccInfo v -- And kill occ info; + -- see Note [Case alternative occ info] + +addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv +addAltUnfoldings env scrut case_bndr con_app + = do { let con_app_unf = mk_simple_unf con_app + env1 = addBinderUnfolding env case_bndr con_app_unf + + -- See Note [Add unfolding for scrutinee] + env2 | Many <- idMult case_bndr = case scrut of + Just (Var v) -> addBinderUnfolding env1 v con_app_unf + Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ + mk_simple_unf (Cast con_app (mkSymCo co)) + _ -> env1 + | otherwise = env1 + + ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) + ; return env2 } + where + -- Force the opts, so that the whole SimplEnv isn't retained + !opts = seUnfoldingOpts env + mk_simple_unf = mkSimpleUnfolding opts + +addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv +addBinderUnfolding env bndr unf + | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf + = warnPprTrace (not (eqType (idType bndr) (exprType tmpl))) + "unfolding type mismatch" + (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $ + modifyInScope env (bndr `setIdUnfolding` unf) + + | otherwise + = modifyInScope env (bndr `setIdUnfolding` unf) + +zapBndrOccInfo :: Bool -> Id -> Id +-- Consider case e of b { (a,b) -> ... } +-- Then if we bind b to (a,b) in "...", and b is not dead, +-- then we must zap the deadness info on a,b +zapBndrOccInfo keep_occ_info pat_id + | keep_occ_info = pat_id + | otherwise = zapIdOccInfo pat_id + +{- Note [Case binder evaluated-ness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pin on a (OtherCon []) unfolding to the case-binder of a Case, +even though it'll be over-ridden in every case alternative with a more +informative unfolding. Why? Because suppose a later, less clever, pass +simply replaces all occurrences of the case binder with the binder itself; +then Lint may complain about the let-can-float invariant. Example + case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in .... + ; K -> blah } + +The let-can-float invariant requires that y is evaluated in the call to +reallyUnsafePtrEquality#, which it is. But we still want that to be true if we +propagate binders to occurrences. + +This showed up in #13027. + +Note [Add unfolding for scrutinee] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general it's unlikely that a variable scrutinee will appear +in the case alternatives case x of { ...x unlikely to appear... } +because the binder-swap in OccurAnal has got rid of all such occurrences +See Note [Binder swap] in "GHC.Core.Opt.OccurAnal". + +BUT it is still VERY IMPORTANT to add a suitable unfolding for a +variable scrutinee, in simplAlt. Here's why + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +There is no occurrence of 'b' in the (...(f y)...). But y gets +the unfolding (a,b), and *that* mentions b. If f has a RULE + RULE f (p, I# q) = ... +we want that rule to match, so we must extend the in-scope env with a +suitable unfolding for 'y'. It's *essential* for rule matching; but +it's also good for case-elimination -- suppose that 'f' was inlined +and did multi-level case analysis, then we'd solve it in one +simplifier sweep instead of two. + +Exactly the same issue arises in GHC.Core.Opt.SpecConstr; +see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr + +HOWEVER, given + case x of y { Just a -> r1; Nothing -> r2 } +we do not want to add the unfolding x -> y to 'x', which might seem cool, +since 'y' itself has different unfoldings in r1 and r2. Reason: if we +did that, we'd have to zap y's deadness info and that is a very useful +piece of information. + +So instead we add the unfolding x -> Just a, and x -> Nothing in the +respective RHSs. + +Since this transformation is tantamount to a binder swap, the same caveat as in +Note [Suppressing binder-swaps on linear case] in OccurAnal apply. + + +************************************************************************ +* * +\subsection{Known constructor} +* * +************************************************************************ + +We are a bit careful with occurrence info. Here's an example + + (\x* -> case x of (a*, b) -> f a) (h v, e) + +where the * means "occurs once". This effectively becomes + case (h v, e) of (a*, b) -> f a) +and then + let a* = h v; b = e in f a +and then + f (h v) + +All this should happen in one sweep. +-} + +knownCon :: SimplEnv + -> OutExpr -- The scrutinee + -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) + -> InId -> [InBndr] -> InExpr -- The alternative + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont + = do { (floats1, env1) <- bind_args env bs dc_args + ; (floats2, env2) <- bind_case_bndr env1 + ; (floats3, expr') <- simplExprF env2 rhs cont + ; case dc_floats of + [] -> + return (floats1 `addFloats` floats2 `addFloats` floats3, expr') + _ -> + return ( emptyFloats env + -- See Note [FloatBinds from constructor wrappers] + , GHC.Core.Make.wrapFloats dc_floats $ + wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') } + where + zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId + + -- Ugh! + bind_args env' [] _ = return (emptyFloats env', env') + + bind_args env' (b:bs') (Type ty : args) + = assert (isTyVar b ) + bind_args (extendTvSubst env' b ty) bs' args + + bind_args env' (b:bs') (Coercion co : args) + = assert (isCoVar b ) + bind_args (extendCvSubst env' b co) bs' args + + bind_args env' (b:bs') (arg : args) + = assert (isId b) $ + do { let b' = zap_occ b + -- Note that the binder might be "dead", because it doesn't + -- occur in the RHS; and simplNonRecX may therefore discard + -- it via postInlineUnconditionally. + -- Nevertheless we must keep it if the case-binder is alive, + -- because it may be used in the con_app. See Note [knownCon occ info] + ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let-can-float invariant + ; (floats2, env3) <- bind_args env2 bs' args + ; return (floats1 `addFloats` floats2, env3) } + + bind_args _ _ _ = + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ + text "scrut:" <+> ppr scrut + + -- It's useful to bind bndr to scrut, rather than to a fresh + -- binding x = Con arg1 .. argn + -- because very often the scrut is a variable, so we avoid + -- creating, and then subsequently eliminating, a let-binding + -- BUT, if scrut is a not a variable, we must be careful + -- about duplicating the arg redexes; in that case, make + -- a new con-app from the args + bind_case_bndr env + | isDeadBinder bndr = return (emptyFloats env, env) + | exprIsTrivial scrut = return (emptyFloats env + , extendIdSubst env bndr (DoneEx scrut Nothing)) + -- See Note [Do not duplicate constructor applications] + | otherwise = do { dc_args <- mapM (simplVar env) bs + -- dc_ty_args are already OutTypes, + -- but bs are InBndrs + ; let con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` dc_args + ; simplNonRecX env bndr con_app } + +------------------- +missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont + -> SimplM (SimplFloats, OutExpr) + -- This isn't strictly an error, although it is unusual. + -- It's possible that the simplifier might "see" that + -- an inner case has no accessible alternatives before + -- it "sees" that the entire branch of an outer case is + -- inaccessible. So we simply put an error case here instead. +missingAlt env case_bndr _ cont + = warnPprTrace True "missingAlt" (ppr case_bndr) $ + -- See Note [Avoiding space leaks in OutType] + let cont_ty = contResultType cont + in seqType cont_ty `seq` + return (emptyFloats env, mkImpossibleExpr cont_ty) + +{- +************************************************************************ +* * +\subsection{Duplicating continuations} +* * +************************************************************************ + +Consider + let x* = case e of { True -> e1; False -> e2 } + in b +where x* is a strict binding. Then mkDupableCont will be given +the continuation + case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop +and will split it into + dupable: case [] of { True -> $j1; False -> $j2 } ; stop + join floats: $j1 = e1, $j2 = e2 + non_dupable: let x* = [] in b; stop + +Putting this back together would give + let x* = let { $j1 = e1; $j2 = e2 } in + case e of { True -> $j1; False -> $j2 } + in b +(Of course we only do this if 'e' wants to duplicate that continuation.) +Note how important it is that the new join points wrap around the +inner expression, and not around the whole thing. + +In contrast, any let-bindings introduced by mkDupableCont can wrap +around the entire thing. + +Note [Bottom alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + case (case x of { A -> error .. ; B -> e; C -> error ..) + of alts +then we can just duplicate those alts because the A and C cases +will disappear immediately. This is more direct than creating +join points and inlining them away. See #4930. +-} + +-------------------- +mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont + -> SimplM ( SimplFloats -- Join points (if any) + , SimplEnv -- Use this for the alts + , SimplCont) +mkDupableCaseCont env alts cont + | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont + ; let env' = bumpCaseDepth $ + env `setInScopeFromF` floats + ; return (floats, env', cont) } + | otherwise = return (emptyFloats env, env, cont) + +altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative +altsWouldDup [] = False -- See Note [Bottom alternatives] +altsWouldDup [_] = False +altsWouldDup (alt:alts) + | is_bot_alt alt = altsWouldDup alts + | otherwise = not (all is_bot_alt alts) + -- otherwise case: first alt is non-bot, so all the rest must be bot + where + is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs + +------------------------- +mkDupableCont :: SimplEnv + -> SimplCont + -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with + -- extra let/join-floats and in-scope variables + , SimplCont) -- dup_cont: duplicable continuation +mkDupableCont env cont + = mkDupableContWithDmds env (repeat topDmd) cont + +mkDupableContWithDmds + :: SimplEnv -> [Demand] -- Demands on arguments; always infinite + -> SimplCont -> SimplM ( SimplFloats, SimplCont) + +mkDupableContWithDmds env _ cont + | contIsDupable cont + = return (emptyFloats env, cont) + +mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn + +mkDupableContWithDmds env dmds (CastIt ty cont) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, CastIt ty cont') } + +-- Duplicating ticks for now, not sure if this is good or not +mkDupableContWithDmds env dmds (TickIt t cont) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, TickIt t cont') } + +mkDupableContWithDmds env _ + (StrictBind { sc_bndr = bndr, sc_body = body + , sc_env = se, sc_cont = cont}) +-- See Note [Duplicating StrictBind] +-- K[ let x = <> in b ] --> join j x = K[ b ] +-- j <> + = do { let sb_env = se `setInScopeFromE` env + ; (sb_env1, bndr') <- simplBinder sb_env bndr + ; (floats1, join_inner) <- simplLam sb_env1 body cont + -- No need to use mkDupableCont before simplLam; we + -- use cont once here, and then share the result if necessary + + ; let join_body = wrapFloats floats1 join_inner + res_ty = contResultType cont + + ; mkDupableStrictBind env bndr' join_body res_ty } + +mkDupableContWithDmds env _ + (StrictArg { sc_fun = fun, sc_cont = cont + , sc_fun_ty = fun_ty }) + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + | isNothing (isDataConId_maybe (ai_fun fun)) + , thumbsUpPlanA cont -- See point (3) of Note [Duplicating join points] + = -- Use Plan A of Note [Duplicating StrictArg] + do { let (_ : dmds) = ai_dmds fun + ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + -- Use the demands from the function to add the right + -- demand info on any bindings we make for further args + ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env) + (ai_args fun) + ; return ( foldl' addLetFloats floats1 floats_s + , StrictArg { sc_fun = fun { ai_args = args' } + , sc_cont = cont' + , sc_fun_ty = fun_ty + , sc_dup = OkToDup} ) } + + | otherwise + = -- Use Plan B of Note [Duplicating StrictArg] + -- K[ f a b <> ] --> join j x = K[ f a b x ] + -- j <> + do { let rhs_ty = contResultType cont + (m,arg_ty,_) = splitFunTy fun_ty + ; arg_bndr <- newId (fsLit "arg") m arg_ty + ; let env' = env `addNewInScopeIds` [arg_bndr] + ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont + ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } + where + thumbsUpPlanA (StrictArg {}) = False + thumbsUpPlanA (CastIt _ k) = thumbsUpPlanA k + thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k + thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k + thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k + thumbsUpPlanA (Select {}) = True + thumbsUpPlanA (StrictBind {}) = True + thumbsUpPlanA (Stop {}) = True + +mkDupableContWithDmds env dmds + (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, ApplyToTy { sc_cont = cont' + , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } + +mkDupableContWithDmds env dmds + (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se + , sc_cont = cont, sc_hole_ty = hole_ty }) + = -- e.g. [...hole...] (...arg...) + -- ==> + -- let a = ...arg... + -- in [...hole...] a + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { let (dmd:cont_dmds) = dmds -- Never fails + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont + ; let env' = env `setInScopeFromF` floats1 + ; (_, se', arg') <- simplArg env' dup se arg + ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' + ; let all_floats = floats1 `addLetFloats` let_floats2 + ; return ( all_floats + , ApplyToVal { sc_arg = arg'' + , sc_env = se' `setInScopeFromF` all_floats + -- Ensure that sc_env includes the free vars of + -- arg'' in its in-scope set, even if makeTrivial + -- has turned arg'' into a fresh variable + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup, sc_cont = cont' + , sc_hole_ty = hole_ty }) } + +mkDupableContWithDmds env _ + (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) + = -- e.g. (case [...hole...] of { pi -> ei }) + -- ===> + -- let ji = \xij -> ei + -- in case [...hole...] of { pi -> ji xij } + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { tick (CaseOfCase case_bndr) + ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont + -- NB: We call mkDupableCaseCont here to make cont duplicable + -- (if necessary, depending on the number of alts) + -- And this is important: see Note [Fusing case continuations] + + ; let cont_scaling = contHoleScaling cont + -- See Note [Scaling in case-of-case] + ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr) + ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts) + -- Safe to say that there are no handled-cons for the DEFAULT case + -- NB: simplBinder does not zap deadness occ-info, so + -- a dead case_bndr' will still advertise its deadness + -- This is really important because in + -- case e of b { (# p,q #) -> ... } + -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), + -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. + -- In the new alts we build, we have the new case binder, so it must retain + -- its deadness. + -- NB: we don't use alt_env further; it has the substEnv for + -- the alternatives, and we don't want that + + ; let platform = sePlatform env + ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt platform case_bndr') + emptyJoinFloats alts' + + ; let all_floats = floats `addJoinFloats` join_floats + -- Note [Duplicated env] + ; return (all_floats + , Select { sc_dup = OkToDup + , sc_bndr = case_bndr' + , sc_alts = alts'' + , sc_env = zapSubstEnv se `setInScopeFromF` all_floats + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_cont = mkBoringStop (contResultType cont) } ) } + +mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType + -> SimplM (SimplFloats, SimplCont) +mkDupableStrictBind env arg_bndr join_rhs res_ty + | exprIsTrivial join_rhs -- See point (2) of Note [Duplicating join points] + = return (emptyFloats env + , StrictBind { sc_bndr = arg_bndr + , sc_body = join_rhs + , sc_env = zapSubstEnv env + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup + , sc_cont = mkBoringStop res_ty } ) + | otherwise + = do { join_bndr <- newJoinId [arg_bndr] res_ty + ; let arg_info = ArgInfo { ai_fun = join_bndr + , ai_rules = Nothing, ai_args = [] + , ai_encl = False, ai_dmds = repeat topDmd + , ai_discs = repeat 0 } + ; return ( addJoinFloats (emptyFloats env) $ + unitJoinFloat $ + NonRec join_bndr $ + Lam (setOneShotLambda arg_bndr) join_rhs + , StrictArg { sc_dup = OkToDup + , sc_fun = arg_info + , sc_fun_ty = idType join_bndr + , sc_cont = mkBoringStop res_ty + } ) } + +mkDupableAlt :: Platform -> OutId + -> JoinFloats -> OutAlt + -> SimplM (JoinFloats, OutAlt) +mkDupableAlt _platform case_bndr jfloats (Alt con alt_bndrs alt_rhs_in) + | exprIsTrivial alt_rhs_in -- See point (2) of Note [Duplicating join points] + = return (jfloats, Alt con alt_bndrs alt_rhs_in) + + | otherwise + = do { let rhs_ty' = exprType alt_rhs_in + + bangs + | DataAlt c <- con + = dataConRepStrictness c + | otherwise = [] + + abstracted_binders = abstract_binders alt_bndrs bangs + + abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)] + abstract_binders [] [] + -- Abstract over the case binder too if it's used. + | isDeadBinder case_bndr = [] + | otherwise = [(case_bndr,MarkedStrict)] + abstract_binders (alt_bndr:alt_bndrs) marks + -- Abstract over all type variables just in case + | isTyVar alt_bndr = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks + abstract_binders (alt_bndr:alt_bndrs) (mark:marks) + -- The deadness info on the new Ids is preserved by simplBinders + -- We don't abstract over dead ids here. + | isDeadBinder alt_bndr = abstract_binders alt_bndrs marks + | otherwise = (alt_bndr,mark) : abstract_binders alt_bndrs marks + abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in) + + filtered_binders = map fst abstracted_binders + -- We want to make any binder with an evaldUnfolding strict in the rhs. + -- See Note [Call-by-value for worker args] (which also applies to join points) + (rhs_with_seqs) = mkStrictFieldSeqs abstracted_binders alt_rhs_in + + final_args = varsToCoreExprs filtered_binders + -- Note [Join point abstraction] + + -- We make the lambdas into one-shot-lambdas. The + -- join point is sure to be applied at most once, and doing so + -- prevents the body of the join point being floated out by + -- the full laziness pass + final_bndrs = map one_shot filtered_binders + one_shot v | isId v = setOneShotLambda v + | otherwise = v + + -- No lambda binder has an unfolding, but (currently) case binders can, + -- so we must zap them here. + join_rhs = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs + + ; join_bndr <- newJoinId filtered_binders rhs_ty' + + ; let join_call = mkApps (Var join_bndr) final_args + alt' = Alt con alt_bndrs join_call + + ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) + , alt') } + -- See Note [Duplicated env] + +{- +Note [Fusing case continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to fuse two successive case continuations when the +first has one alternative. That's why we call prepareCaseCont here. +Consider this, which arises from thunk splitting (see Note [Thunk +splitting] in GHC.Core.Opt.WorkWrap): + + let + x* = case (case v of {pn -> rn}) of + I# a -> I# a + in body + +The simplifier will find + (Var v) with continuation + Select (pn -> rn) ( + Select [I# a -> I# a] ( + StrictBind body Stop + +So we'll call mkDupableCont on + Select [I# a -> I# a] (StrictBind body Stop) +There is just one alternative in the first Select, so we want to +simplify the rhs (I# a) with continuation (StrictBind body Stop) +Supposing that body is big, we end up with + let $j a = <let x = I# a in body> + in case v of { pn -> case rn of + I# a -> $j a } +This is just what we want because the rn produces a box that +the case rn cancels with. + +See #4957 a fuller example. + +Note [Duplicating join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +IN #19996 we discovered that we want to be really careful about +inlining join points. Consider + case (join $j x = K f x ) + (in case v of ) + ( p1 -> $j x1 ) of + ( p2 -> $j x2 ) + ( p3 -> $j x3 ) + K g y -> blah[g,y] + +Here the join-point RHS is very small, just a constructor +application (K x y). So we might inline it to get + case (case v of ) + ( p1 -> K f x1 ) of + ( p2 -> K f x2 ) + ( p3 -> K f x3 ) + K g y -> blah[g,y] + +But now we have to make `blah` into a join point, /abstracted/ +over `g` and `y`. In contrast, if we /don't/ inline $j we +don't need a join point for `blah` and we'll get + join $j x = let g=f, y=x in blah[g,y] + in case v of + p1 -> $j x1 + p2 -> $j x2 + p3 -> $j x3 + +This can make a /massive/ difference, because `blah` can see +what `f` is, instead of lambda-abstracting over it. + +To achieve this: + +1. Do not postInlineUnconditionally a join point, until the Final + phase. (The Final phase is still quite early, so we might consider + delaying still more.) + +2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for + all alternatives, except for exprIsTrival RHSs. Previously we used + exprIsDupable. This generates a lot more join points, but makes + them much more case-of-case friendly. + + It is definitely worth checking for exprIsTrivial, otherwise we get + an extra Simplifier iteration, because it is inlined in the next + round. + +3. By the same token we want to use Plan B in + Note [Duplicating StrictArg] when the RHS of the new join point + is a data constructor application. That same Note explains why we + want Plan A when the RHS of the new join point would be a + non-data-constructor application + +4. You might worry that $j will be inlined by the call-site inliner, + but it won't because the call-site context for a join is usually + extremely boring (the arguments come from the pattern match). + And if not, then perhaps inlining it would be a good idea. + + You might also wonder if we get UnfWhen, because the RHS of the + join point is no bigger than the call. But in the cases we care + about it will be a little bigger, because of that free `f` in + $j x = K f x + So for now we don't do anything special in callSiteInline + +There is a bit of tension between (2) and (3). Do we want to retain +the join point only when the RHS is +* a constructor application? or +* just non-trivial? +Currently, a bit ad-hoc, but we definitely want to retain the join +point for data constructors in mkDupalbleALt (point 2); that is the +whole point of #19996 described above. + +Historical Note [Case binders and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: this entire Note is now irrelevant. In Jun 21 we stopped +adding unfoldings to lambda binders (#17530). It was always a +hack and bit us in multiple small and not-so-small ways + +Consider this + case (case .. ) of c { + I# c# -> ....c.... + +If we make a join point with c but not c# we get + $j = \c -> ....c.... + +But if later inlining scrutinises the c, thus + + $j = \c -> ... case c of { I# y -> ... } ... + +we won't see that 'c' has already been scrutinised. This actually +happens in the 'tabulate' function in wave4main, and makes a significant +difference to allocation. + +An alternative plan is this: + + $j = \c# -> let c = I# c# in ...c.... + +but that is bad if 'c' is *not* later scrutinised. + +So instead we do both: we pass 'c' and 'c#' , and record in c's inlining +(a stable unfolding) that it's really I# c#, thus + + $j = \c# -> \c[=I# c#] -> ...c.... + +Absence analysis may later discard 'c'. + +NB: take great care when doing strictness analysis; + see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal. + +Also note that we can still end up passing stuff that isn't used. Before +strictness analysis we have + let $j x y c{=(x,y)} = (h c, ...) + in ... +After strictness analysis we see that h is strict, we end up with + let $j x y c{=(x,y)} = ($wh x y, ...) +and c is unused. + +Note [Duplicated env] +~~~~~~~~~~~~~~~~~~~~~ +Some of the alternatives are simplified, but have not been turned into a join point +So they *must* have a zapped subst-env. So we can't use completeNonRecX to +bind the join point, because it might to do PostInlineUnconditionally, and +we'd lose that when zapping the subst-env. We could have a per-alt subst-env, +but zapping it (as we do in mkDupableCont, the Select case) is safe, and +at worst delays the join-point inlining. + +Note [Funky mkLamTypes] +~~~~~~~~~~~~~~~~~~~~~~ +Notice the funky mkLamTypes. If the constructor has existentials +it's possible that the join point will be abstracted over +type variables as well as term variables. + Example: Suppose we have + data T = forall t. C [t] + Then faced with + case (case e of ...) of + C t xs::[t] -> rhs + We get the join point + let j :: forall t. [t] -> ... + j = /\t \xs::[t] -> rhs + in + case (case e of ...) of + C t xs::[t] -> j t xs + +Note [Duplicating StrictArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dealing with making a StrictArg continuation duplicable has turned out +to be one of the trickiest corners of the simplifier, giving rise +to several cases in which the simplier expanded the program's size +*exponentially*. They include + #13253 exponential inlining + #10421 ditto + #18140 strict constructors + #18282 another nested-function call case + +Suppose we have a call + f e1 (case x of { True -> r1; False -> r2 }) e3 +and f is strict in its second argument. Then we end up in +mkDupableCont with a StrictArg continuation for (f e1 <> e3). +There are two ways to make it duplicable. + +* Plan A: move the entire call inwards, being careful not + to duplicate e1 or e3, thus: + let a1 = e1 + a3 = e3 + in case x of { True -> f a1 r1 a3 + ; False -> f a1 r2 a3 } + +* Plan B: make a join point: + join $j x = f e1 x e3 + in case x of { True -> jump $j r1 + ; False -> jump $j r2 } + + Notice that Plan B is very like the way we handle strict bindings; + see Note [Duplicating StrictBind]. And Plan B is exactly what we'd + get if we turned use a case expression to evaluate the strict arg: + + case (case x of { True -> r1; False -> r2 }) of + r -> f e1 r e3 + + So, looking at Note [Duplicating join points], we also want Plan B + when `f` is a data constructor. + +Plan A is often good. Here's an example from #3116 + go (n+1) (case l of + 1 -> bs' + _ -> Chunk p fpc (o+1) (l-1) bs') + +If we pushed the entire call for 'go' inside the case, we get +call-pattern specialisation for 'go', which is *crucial* for +this particular program. + +Here is another example. + && E (case x of { T -> F; F -> T }) + +Pushing the call inward (being careful not to duplicate E) + let a = E + in case x of { T -> && a F; F -> && a T } + +and now the (&& a F) etc can optimise. Moreover there might +be a RULE for the function that can fire when it "sees" the +particular case alternative. + +But Plan A can have terrible, terrible behaviour. Here is a classic +case: + f (f (f (f (f True)))) + +Suppose f is strict, and has a body that is small enough to inline. +The innermost call inlines (seeing the True) to give + f (f (f (f (case v of { True -> e1; False -> e2 })))) + +Now, suppose we naively push the entire continuation into both +case branches (it doesn't look large, just f.f.f.f). We get + case v of + True -> f (f (f (f e1))) + False -> f (f (f (f e2))) + +And now the process repeats, so we end up with an exponentially large +number of copies of f. No good! + +CONCLUSION: we want Plan A in general, but do Plan B is there a +danger of this nested call behaviour. The function that decides +this is called thumbsUpPlanA. + +Note [Keeping demand info in StrictArg Plan A] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Following on from Note [Duplicating StrictArg], another common code +pattern that can go bad is this: + f (case x1 of { T -> F; F -> T }) + (case x2 of { T -> F; F -> T }) + ...etc... +when f is strict in all its arguments. (It might, for example, be a +strict data constructor whose wrapper has not yet been inlined.) + +We use Plan A (because there is no nesting) giving + let a2 = case x2 of ... + a3 = case x3 of ... + in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... } + +Now we must be careful! a2 and a3 are small, and the OneOcc code in +postInlineUnconditionally may inline them both at both sites; see Note +Note [Inline small things to avoid creating a thunk] in +Simplify.Utils. But if we do inline them, the entire process will +repeat -- back to exponential behaviour. + +So we are careful to keep the demand-info on a2 and a3. Then they'll +be /strict/ let-bindings, which will be dealt with by StrictBind. +That's why contIsDupableWithDmds is careful to propagage demand +info to the auxiliary bindings it creates. See the Demand argument +to makeTrivial. + +Note [Duplicating StrictBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We make a StrictBind duplicable in a very similar way to +that for case expressions. After all, + let x* = e in b is similar to case e of x -> b + +So we potentially make a join-point for the body, thus: + let x = <> in b ==> join j x = b + in j <> + +Just like StrictArg in fact -- and indeed they share code. + +Note [Join point abstraction] Historical note +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: This note is now historical, describing how (in the past) we used +to add a void argument to nullary join points. But now that "join +point" is not a fuzzy concept but a formal syntactic construct (as +distinguished by the JoinId constructor of IdDetails), each of these +concerns is handled separately, with no need for a vestigial extra +argument. + +Join points always have at least one value argument, +for several reasons + +* If we try to lift a primitive-typed something out + for let-binding-purposes, we will *caseify* it (!), + with potentially-disastrous strictness results. So + instead we turn it into a function: \v -> e + where v::Void#. The value passed to this function is void, + which generates (almost) no code. + +* CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now + we make the join point into a function whenever used_bndrs' + is empty. This makes the join-point more CPR friendly. + Consider: let j = if .. then I# 3 else I# 4 + in case .. of { A -> j; B -> j; C -> ... } + + Now CPR doesn't w/w j because it's a thunk, so + that means that the enclosing function can't w/w either, + which is a lose. Here's the example that happened in practice: + kgmod :: Int -> Int -> Int + kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 + then 78 + else 5 + +* Let-no-escape. We want a join point to turn into a let-no-escape + so that it is implemented as a jump, and one of the conditions + for LNE is that it's not updatable. In CoreToStg, see + Note [What is a non-escaping let] + +* Floating. Since a join point will be entered once, no sharing is + gained by floating out, but something might be lost by doing + so because it might be allocated. + +I have seen a case alternative like this: + True -> \v -> ... +It's a bit silly to add the realWorld dummy arg in this case, making + $j = \s v -> ... + True -> $j s +(the \v alone is enough to make CPR happy) but I think it's rare + +There's a slight infelicity here: we pass the overall +case_bndr to all the join points if it's used in *any* RHS, +because we don't know its usage in each RHS separately + + + +************************************************************************ +* * + Unfoldings +* * +************************************************************************ +-} + +simplLetUnfolding :: SimplEnv + -> BindContext + -> InId + -> OutExpr -> OutType -> ArityType + -> Unfolding -> SimplM Unfolding +simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf + | isStableUnfolding unf + = simplStableUnfolding env bind_cxt id rhs_ty arity unf + | isExitJoinId id + = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify + | otherwise + = -- Otherwise, we end up retaining all the SimpleEnv + let !opts = seUnfoldingOpts env + in mkLetUnfolding opts (bindContextLevel bind_cxt) InlineRhs id new_rhs + +------------------- +mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource + -> InId -> OutExpr -> SimplM Unfolding +mkLetUnfolding !uf_opts top_lvl src id new_rhs + = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs) + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In GHC.Iface.Tidy we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. + where + -- Might as well force this, profiles indicate up to 0.5MB of thunks + -- just from this site. + !is_top_lvl = isTopLevel top_lvl + -- See Note [Force bottoming field] + !is_bottoming = isDeadEndId id + +------------------- +simplStableUnfolding :: SimplEnv -> BindContext + -> InId + -> OutType + -> ArityType -- Used to eta expand, but only for non-join-points + -> Unfolding + ->SimplM Unfolding +-- Note [Setting the new unfolding] +simplStableUnfolding env bind_cxt id rhs_ty id_arity unf + = case unf of + NoUnfolding -> return unf + BootUnfolding -> return unf + OtherCon {} -> return unf + + DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } + -> do { (env', bndrs') <- simplBinders unf_env bndrs + ; args' <- mapM (simplExpr env') args + ; return (mkDFunUnfolding bndrs' con args') } + + CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } + | isStableSource src + -> do { expr' <- case bind_cxt of + BC_Join cont -> -- Binder is a join point + -- See Note [Rules and unfolding for join points] + simplJoinRhs unf_env id expr cont + BC_Let _ is_rec -> -- Binder is not a join point + do { let cont = mkRhsStop rhs_ty is_rec topDmd + -- mkRhsStop: switch off eta-expansion at the top level + ; expr' <- simplExprC unf_env expr cont + ; return (eta_expand expr') } + ; case guide of + UnfWhen { ug_arity = arity + , ug_unsat_ok = sat_ok + , ug_boring_ok = boring_ok + } + -- Happens for INLINE things + -- Really important to force new_boring_ok as otherwise + -- `ug_boring_ok` is a thunk chain of + -- inlineBoringExprOk expr0 + -- || inlineBoringExprOk expr1 || ... + -- See #20134 + -> let !new_boring_ok = boring_ok || inlineBoringOk expr' + guide' = + UnfWhen { ug_arity = arity + , ug_unsat_ok = sat_ok + , ug_boring_ok = new_boring_ok + + } + -- Refresh the boring-ok flag, in case expr' + -- has got small. This happens, notably in the inlinings + -- for dfuns for single-method classes; see + -- Note [Single-method classes] in GHC.Tc.TyCl.Instance. + -- A test case is #4138 + -- But retain a previous boring_ok of True; e.g. see + -- the way it is set in calcUnfoldingGuidanceWithArity + in return (mkCoreUnfolding src is_top_lvl expr' guide') + -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold + + _other -- Happens for INLINABLE things + -> mkLetUnfolding uf_opts top_lvl src id expr' } + -- If the guidance is UnfIfGoodArgs, this is an INLINABLE + -- unfolding, and we need to make sure the guidance is kept up + -- to date with respect to any changes in the unfolding. + + | otherwise -> return noUnfolding -- Discard unstable unfoldings + where + uf_opts = seUnfoldingOpts env + -- Forcing this can save about 0.5MB of max residency and the result + -- is small and easy to compute so might as well force it. + top_lvl = bindContextLevel bind_cxt + !is_top_lvl = isTopLevel top_lvl + act = idInlineActivation id + unf_env = updMode (updModeForStableUnfoldings act) env + -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils + + -- See Note [Eta-expand stable unfoldings] + -- Use the arity from the main Id (in id_arity), rather than computing it from rhs + eta_expand expr | seEtaExpand env + , exprArity expr < arityTypeArity id_arity + , wantEtaExpansion expr + = etaExpandAT (getInScope env) id_arity expr + | otherwise + = expr + +{- Note [Eta-expand stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For INLINE/INLINABLE things (which get stable unfoldings) there's a danger +of getting + f :: Int -> Int -> Int -> Blah + [ Arity = 3 -- Good arity + , Unf=Stable (\xy. blah) -- Less good arity, only 2 + f = \pqr. e + +This can happen because f's RHS is optimised more vigorously than +its stable unfolding. Now suppose we have a call + g = f x +Because f has arity=3, g will have arity=2. But if we inline f (using +its stable unfolding) g's arity will reduce to 1, because <blah> +hasn't been optimised yet. This happened in the 'parsec' library, +for Text.Pasec.Char.string. + +Generally, if we know that 'f' has arity N, it seems sensible to +eta-expand the stable unfolding to arity N too. Simple and consistent. + +Wrinkles + +* See Historical-note [Eta-expansion in stable unfoldings] in + GHC.Core.Opt.Simplify.Utils + +* Don't eta-expand a trivial expr, else each pass will eta-reduce it, + and then eta-expand again. See Note [Which RHSs do we eta-expand?] + in GHC.Core.Opt.Simplify.Utils. + +* Don't eta-expand join points; see Note [Do not eta-expand join points] + in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point + case (bind_cxt = BC_Join _) doesn't use eta_expand. + +Note [Force bottoming field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to force bottoming, or the new unfolding holds +on to the old unfolding (which is part of the id). + +Note [Setting the new unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If there's an INLINE pragma, we simplify the RHS gently. Maybe we + should do nothing at all, but simplifying gently might get rid of + more crap. + +* If not, we make an unfolding from the new RHS. But *only* for + non-loop-breakers. Making loop breakers not have an unfolding at all + means that we can avoid tests in exprIsConApp, for example. This is + important: if exprIsConApp says 'yes' for a recursive thing, then we + can get into an infinite loop + +If there's a stable unfolding on a loop breaker (which happens for +INLINABLE), we hang on to the inlining. It's pretty dodgy, but the +user did say 'INLINE'. May need to revisit this choice. + +************************************************************************ +* * + Rules +* * +************************************************************************ + +Note [Rules in a letrec] +~~~~~~~~~~~~~~~~~~~~~~~~ +After creating fresh binders for the binders of a letrec, we +substitute the RULES and add them back onto the binders; this is done +*before* processing any of the RHSs. This is important. Manuel found +cases where he really, really wanted a RULE for a recursive function +to apply in that function's own right-hand side. + +See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal" +-} + +addBndrRules :: SimplEnv -> InBndr -> OutBndr + -> BindContext + -> SimplM (SimplEnv, OutBndr) +-- Rules are added back into the bin +addBndrRules env in_id out_id bind_cxt + | null old_rules + = return (env, out_id) + | otherwise + = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt + ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules + ; return (modifyInScope env final_id, final_id) } + where + old_rules = ruleInfoRules (idSpecialisation in_id) + +simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule] +-- Simplify local rules for imported Ids +simplImpRules env rules + = simplRules env Nothing rules (BC_Let TopLevel NonRecursive) + +simplRules :: SimplEnv -> Maybe OutId -> [CoreRule] + -> BindContext -> SimplM [CoreRule] +simplRules env mb_new_id rules bind_cxt + = mapM simpl_rule rules + where + simpl_rule rule@(BuiltinRule {}) + = return rule + + simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs + , ru_act = act }) + = do { (env', bndrs') <- simplBinders env bndrs + ; let rhs_ty = substTy env' (exprType rhs) + rhs_cont = case bind_cxt of -- See Note [Rules and unfolding for join points] + BC_Let {} -> mkBoringStop rhs_ty + BC_Join cont -> assertPpr join_ok bad_join_msg cont + lhs_env = updMode updModeForRules env' + rhs_env = updMode (updModeForStableUnfoldings act) env' + -- See Note [Simplifying the RHS of a RULE] + fn_name' = case mb_new_id of + Just id -> idName id + Nothing -> fn_name + + -- join_ok is an assertion check that the join-arity of the + -- binder matches that of the rule, so that pushing the + -- continuation into the RHS makes sense + join_ok = case mb_new_id of + Just id | Just join_arity <- isJoinId_maybe id + -> length args == join_arity + _ -> False + bad_join_msg = vcat [ ppr mb_new_id, ppr rule + , ppr (fmap isJoinId_maybe mb_new_id) ] + + ; args' <- mapM (simplExpr lhs_env) args + ; rhs' <- simplExprC rhs_env rhs rhs_cont + ; return (rule { ru_bndrs = bndrs' + , ru_fn = fn_name' + , ru_args = args' + , ru_rhs = rhs' }) } + +{- Note [Simplifying the RHS of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can simplify the RHS of a RULE much as we do the RHS of a stable +unfolding. We used to use the much more conservative updModeForRules +for the RHS as well as the LHS, but that seems more conservative +than necesary. Allowing some inlining might, for example, eliminate +a binding. +-} diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs index 33318f5d58..b20bf0a8ad 100644 --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -7,9 +7,9 @@ module GHC.Core.Opt.Simplify.Monad ( -- The monad - SimplM, + TopEnvConfig(..), SimplM, initSmpl, traceSmpl, - getSimplRules, getFamEnvs, getOptCoercionOpts, + getSimplRules, -- Unique supply MonadUnique(..), newId, newJoinId, @@ -27,15 +27,11 @@ import GHC.Types.Name ( mkSystemVarName ) import GHC.Types.Id ( Id, mkSysLocalOrCoVarM ) import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) import GHC.Core.Type ( Type, Mult ) -import GHC.Core.FamInstEnv ( FamInstEnv ) -import GHC.Core ( RuleEnv(..), RuleBase) -import GHC.Core.Rules +import GHC.Core ( RuleEnv(..) ) +import GHC.Core.Opt.Stats import GHC.Core.Utils ( mkLamTypes ) -import GHC.Core.Coercion.Opt import GHC.Types.Unique.Supply -import GHC.Driver.Session -import GHC.Driver.Config -import GHC.Core.Opt.Monad +import GHC.Driver.Flags import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Monad @@ -53,13 +49,10 @@ import GHC.Exts( oneShot ) \subsection{Monad plumbing} * * ************************************************************************ - -For the simplifier monad, we want to {\em thread} a unique supply and a counter. -(Command-line switches move around through the explicitly-passed SimplEnv.) -} newtype SimplM result - = SM' { unSM :: SimplTopEnv -- Envt that does not change much + = SM' { unSM :: SimplTopEnv -> SimplCount -> IO (result, SimplCount)} -- We only need IO here for dump output, but since we already have it @@ -76,54 +69,53 @@ pattern SM m <- SM' m where SM m = SM' (oneShot $ \env -> oneShot $ \ct -> m env ct) +-- See Note [The environments of the Simplify pass] +data TopEnvConfig = TopEnvConfig + { te_history_size :: !Int + , te_tick_factor :: !Int + } + data SimplTopEnv - = STE { st_flags :: DynFlags + = STE { -- See Note [The environments of the Simplify pass] + st_config :: !TopEnvConfig , st_logger :: !Logger - , st_max_ticks :: IntWithInf -- ^ Max #ticks in this simplifier run - , st_query_rulebase :: IO RuleBase - -- ^ The action to retrieve an up-to-date EPS RuleBase + , st_max_ticks :: !IntWithInf -- ^ Max #ticks in this simplifier run + , st_read_ruleenv :: !(IO RuleEnv) + -- ^ The action to retrieve an up-to-date EPS RuleEnv -- See Note [Overall plumbing for rules] - , st_mod_rules :: RuleEnv - , st_fams :: (FamInstEnv, FamInstEnv) - - , st_co_opt_opts :: !OptCoercionOpts - -- ^ Coercion optimiser options } -initSmpl :: Logger -> DynFlags -> IO RuleBase -> RuleEnv -> (FamInstEnv, FamInstEnv) - -> Int -- Size of the bindings, used to limit - -- the number of ticks we allow +initSmpl :: Logger + -> IO RuleEnv + -> TopEnvConfig + -> Int -- ^ Size of the bindings, used to limit the number of ticks we allow -> SimplM a -> IO (a, SimplCount) -initSmpl logger dflags qrb rules fam_envs size m +initSmpl logger read_ruleenv cfg size m = do -- No init count; set to 0 - let simplCount = zeroSimplCount dflags - (result, count) <- unSM m env simplCount - return (result, count) + let simplCount = zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats + unSM m env simplCount where - env = STE { st_flags = dflags + env = STE { st_config = cfg , st_logger = logger - , st_query_rulebase = qrb - , st_mod_rules = rules - , st_max_ticks = computeMaxTicks dflags size - , st_fams = fam_envs - , st_co_opt_opts = initOptCoercionOpts dflags + , st_max_ticks = computeMaxTicks cfg size + , st_read_ruleenv = read_ruleenv } -computeMaxTicks :: DynFlags -> Int -> IntWithInf +computeMaxTicks :: TopEnvConfig -> Int -> IntWithInf -- Compute the max simplifier ticks as -- (base-size + pgm-size) * magic-multiplier * tick-factor/100 -- where -- magic-multiplier is a constant that gives reasonable results -- base-size is a constant to deal with size-zero programs -computeMaxTicks dflags size +computeMaxTicks cfg size = treatZeroAsInf $ fromInteger ((toInteger (size + base_size) * toInteger (tick_factor * magic_multiplier)) `div` 100) where - tick_factor = simplTickFactor dflags + tick_factor = te_tick_factor cfg base_size = 100 magic_multiplier = 40 -- MAGIC NUMBER, multiplies the simplTickFactor @@ -196,27 +188,22 @@ instance MonadUnique SimplM where getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplMask getUniqueM = liftIO $ uniqFromMask simplMask -instance HasDynFlags SimplM where - getDynFlags = SM (\st_env sc -> return (st_flags st_env, sc)) - instance HasLogger SimplM where - getLogger = SM (\st_env sc -> return (st_logger st_env, sc)) + getLogger = gets st_logger instance MonadIO SimplM where - liftIO m = SM $ \_ sc -> do - x <- m - return (x, sc) + liftIO = liftIOWithEnv . const getSimplRules :: SimplM RuleEnv -getSimplRules = SM (\st_env sc -> do - eps_rules <- st_query_rulebase st_env - return (extendRuleEnv (st_mod_rules st_env) eps_rules, sc)) +getSimplRules = liftIOWithEnv st_read_ruleenv -getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) -getFamEnvs = SM (\st_env sc -> return (st_fams st_env, sc)) +liftIOWithEnv :: (SimplTopEnv -> IO a) -> SimplM a +liftIOWithEnv m = SM (\st_env sc -> do + x <- m st_env + return (x, sc)) -getOptCoercionOpts :: SimplM OptCoercionOpts -getOptCoercionOpts = SM (\st_env sc -> return (st_co_opt_opts st_env, sc)) +gets :: (SimplTopEnv -> a) -> SimplM a +gets f = liftIOWithEnv (return . f) newId :: FastString -> Mult -> Type -> SimplM Id newId fs w ty = mkSysLocalOrCoVarM fs w ty @@ -248,8 +235,10 @@ getSimplCount :: SimplM SimplCount getSimplCount = SM (\_st_env sc -> return (sc, sc)) tick :: Tick -> SimplM () -tick t = SM (\st_env sc -> let sc' = doSimplTick (st_flags st_env) t sc - in sc' `seq` return ((), sc')) +tick t = SM (\st_env sc -> let + history_size = te_history_size (st_config st_env) + sc' = doSimplTick history_size t sc + in sc' `seq` return ((), sc')) checkedTick :: Tick -> SimplM () -- Try to take a tick, but fail if too many @@ -258,8 +247,10 @@ checkedTick t if st_max_ticks st_env <= mkIntWithInf (simplCountN sc) then throwGhcExceptionIO $ PprProgramError "Simplifier ticks exhausted" (msg sc) - else let sc' = doSimplTick (st_flags st_env) t sc - in sc' `seq` return ((), sc')) + else let + history_size = te_history_size (st_config st_env) + sc' = doSimplTick history_size t sc + in sc' `seq` return ((), sc')) where msg sc = vcat [ text "When trying" <+> ppr t diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 3197b8024b..bca029783c 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -15,7 +15,7 @@ module GHC.Core.Opt.Simplify.Utils ( preInlineUnconditionally, postInlineUnconditionally, activeUnfolding, activeRule, getUnfoldingInRuleMatch, - simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules, + updModeForStableUnfoldings, updModeForRules, -- The BindContext type BindContext(..), bindContextLevel, @@ -43,12 +43,10 @@ module GHC.Core.Opt.Simplify.Utils ( import GHC.Prelude -import GHC.Driver.Session - import GHC.Core import GHC.Types.Literal ( isLitRubbish ) import GHC.Core.Opt.Simplify.Env -import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..), floatEnable ) +import GHC.Core.Opt.Stats ( Tick(..) ) import qualified GHC.Core.Subst import GHC.Core.Ppr import GHC.Core.TyCo.Ppr ( pprParendType ) @@ -64,8 +62,6 @@ import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) import GHC.Core.Multiplicity import GHC.Core.Opt.ConstantFold -import GHC.Driver.Config.Core.Opt.Arity - import GHC.Types.Name import GHC.Types.Id import GHC.Types.Id.Info @@ -80,7 +76,6 @@ import GHC.Data.FastString ( fsLit ) import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Outputable -import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Trace @@ -611,7 +606,7 @@ mkArgInfo env fun rules n_val_args call_cont vanilla_dmds = repeat topDmd arg_dmds - | not (sm_inline (seMode env)) + | not (seInline env) = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False] | otherwise = -- add_type_str fun_ty $ @@ -780,8 +775,8 @@ interestingCallContext env cont = interesting cont where interesting (Select {}) - | sm_case_case (getMode env) = CaseCtxt - | otherwise = BoringCtxt + | seCaseCase env = CaseCtxt + | otherwise = BoringCtxt -- See Note [No case of case is boring] interesting (ApplyToVal {}) = ValAppCtxt @@ -926,41 +921,10 @@ interestingArg env e = go env 0 e SimplMode * * ************************************************************************ - -The SimplMode controls several switches; see its definition in -GHC.Core.Opt.Monad - sm_rules :: Bool -- Whether RULES are enabled - sm_inline :: Bool -- Whether inlining is enabled - sm_case_case :: Bool -- Whether case-of-case is enabled - sm_eta_expand :: Bool -- Whether eta-expansion is enabled -} -simplEnvForGHCi :: Logger -> DynFlags -> SimplEnv -simplEnvForGHCi logger dflags - = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] - , sm_phase = InitialPhase - , sm_logger = logger - , sm_dflags = dflags - , sm_uf_opts = uf_opts - , sm_rules = rules_on - , sm_inline = False - -- Do not do any inlining, in case we expose some - -- unboxed tuple stuff that confuses the bytecode - -- interpreter - , sm_eta_expand = eta_expand_on - , sm_cast_swizzle = True - , sm_case_case = True - , sm_pre_inline = pre_inline_on - , sm_float_enable = float_enable - } - where - rules_on = gopt Opt_EnableRewriteRules dflags - eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags - pre_inline_on = gopt Opt_SimplPreInlining dflags - uf_opts = unfoldingOpts dflags - float_enable = floatEnable dflags - updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode +-- See Note [The environments of the Simplify pass] updModeForStableUnfoldings unf_act current_mode = current_mode { sm_phase = phaseFromActivation unf_act , sm_inline = True } @@ -973,6 +937,7 @@ updModeForStableUnfoldings unf_act current_mode updModeForRules :: SimplMode -> SimplMode -- See Note [Simplifying rules] +-- See Note [The environments of the Simplify pass] updModeForRules current_mode = current_mode { sm_phase = InitialPhase , sm_inline = False @@ -1189,10 +1154,9 @@ getUnfoldingInRuleMatch env = (in_scope, id_unf) where in_scope = seInScope env - mode = getMode env id_unf id | unf_is_active id = idUnfolding id | otherwise = NoUnfolding - unf_is_active id = isActive (sm_phase mode) (idInlineActivation id) + unf_is_active id = isActive (sePhase env) (idInlineActivation id) -- When sm_rules was off we used to test for a /stable/ unfolding, -- but that seems wrong (#20941) @@ -1367,9 +1331,8 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env , occ_int_cxt = IsInteresting } = canInlineInLam rhs one_occ _ = False - pre_inline_unconditionally = sm_pre_inline mode - mode = getMode env - active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag) + pre_inline_unconditionally = sePreInline env + active = isActive (sePhase env) (inlinePragmaActivation inline_prag) -- See Note [pre/postInlineUnconditionally in gentle mode] inline_prag = idInlinePragma bndr @@ -1401,7 +1364,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env -- not ticks. Counting ticks cannot be duplicated, and non-counting -- ticks around a Lam will disappear anyway. - early_phase = sm_phase mode /= FinalPhase + early_phase = sePhase env /= FinalPhase -- If we don't have this early_phase test, consider -- x = length [1,2,3] -- The full laziness pass carefully floats all the cons cells to @@ -1531,7 +1494,7 @@ postInlineUnconditionally env bind_cxt bndr occ_info rhs where unfolding = idUnfolding bndr uf_opts = seUnfoldingOpts env - phase = sm_phase (getMode env) + phase = sePhase env active = isActive phase (idInlineActivation bndr) -- See Note [pre/postInlineUnconditionally in gentle mode] @@ -1659,72 +1622,67 @@ rebuildLam _env [] body _cont = return body rebuildLam env bndrs body cont - = {-# SCC "rebuildLam" #-} - do { dflags <- getDynFlags - ; try_eta dflags bndrs body } + = {-# SCC "rebuildLam" #-} try_eta bndrs body where - mode = getMode env rec_ids = seRecIds env in_scope = getInScope env -- Includes 'bndrs' mb_rhs = contIsRhs cont -- See Note [Eta reduction based on evaluation context] - eval_sd dflags - | gopt Opt_PedanticBottoms dflags = topSubDmd + eval_sd + | sePedanticBottoms env = topSubDmd -- See Note [Eta reduction soundness], criterion (S) -- the bit about -fpedantic-bottoms | otherwise = contEvalContext cont -- NB: cont is never ApplyToVal, because beta-reduction would -- have happened. So contEvalContext can panic on ApplyToVal. - try_eta :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr - try_eta dflags bndrs body + try_eta :: [OutBndr] -> OutExpr -> SimplM OutExpr + try_eta bndrs body | -- Try eta reduction - gopt Opt_DoEtaReduction dflags - , Just etad_lam <- tryEtaReduce rec_ids bndrs body (eval_sd dflags) + seDoEtaReduction env + , Just etad_lam <- tryEtaReduce rec_ids bndrs body eval_sd = do { tick (EtaReduction (head bndrs)) ; return etad_lam } | -- Try eta expansion Nothing <- mb_rhs -- See Note [Eta expanding lambdas] - , sm_eta_expand mode + , seEtaExpand env , any isRuntimeVar bndrs -- Only when there is at least one value lambda already - , Just body_arity <- exprEtaExpandArity (initArityOpts dflags) body + , Just body_arity <- exprEtaExpandArity (seArityOpts env) body = do { tick (EtaExpansion (head bndrs)) ; let body' = etaExpandAT in_scope body_arity body ; traceSmpl "eta expand" (vcat [text "before" <+> ppr body , text "after" <+> ppr body']) -- NB: body' might have an outer Cast, but if so -- mk_lams will pull it further out, past 'bndrs' to the top - ; mk_lams dflags bndrs body' } + ; return (mk_lams bndrs body') } | otherwise - = mk_lams dflags bndrs body + = return (mk_lams bndrs body) - mk_lams :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr + mk_lams :: [OutBndr] -> OutExpr -> OutExpr -- mk_lams pulls casts and ticks to the top - mk_lams dflags bndrs body@(Lam {}) - = mk_lams dflags (bndrs ++ bndrs1) body1 + mk_lams bndrs body@(Lam {}) + = mk_lams (bndrs ++ bndrs1) body1 where (bndrs1, body1) = collectBinders body - mk_lams dflags bndrs (Tick t expr) + mk_lams bndrs (Tick t expr) | tickishFloatable t - = do { expr' <- mk_lams dflags bndrs expr - ; return (mkTick t expr') } + = mkTick t (mk_lams bndrs expr) - mk_lams dflags bndrs (Cast body co) + mk_lams bndrs (Cast body co) | -- Note [Casts and lambdas] - sm_cast_swizzle mode + seCastSwizzle env , not (any bad bndrs) - = do { lam <- mk_lams dflags bndrs body - ; return (mkCast lam (mkPiCos Representational bndrs co)) } + = mkCast (mk_lams bndrs body) (mkPiCos Representational bndrs co) where co_vars = tyCoVarsOfCo co bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars - mk_lams _ bndrs body - = return (mkLams bndrs body) + mk_lams bndrs body + = mkLams bndrs body {- Note [Eta expanding lambdas] @@ -1745,9 +1703,6 @@ better eta-expander (in the form of tryEtaExpandRhs), so we don't bother to try expansion in mkLam in that case; hence the contIsRhs guard. -NB: We check the SimplEnv (sm_eta_expand), not DynFlags. - See Historical-note [Eta-expansion in stable unfoldings] - Note [Casts and lambdas] ~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1834,7 +1789,7 @@ tryEtaExpandRhs _env (BC_Join {}) bndr rhs = pprPanic "tryEtaExpandRhs" (ppr bndr) tryEtaExpandRhs env (BC_Let _ is_rec) bndr rhs - | sm_eta_expand mode -- Provided eta-expansion is on + | seEtaExpand env -- Provided eta-expansion is on , new_arity > old_arity -- And the current manifest arity isn't enough , wantEtaExpansion rhs = do { tick (EtaExpansion bndr) @@ -1843,10 +1798,8 @@ tryEtaExpandRhs env (BC_Let _ is_rec) bndr rhs | otherwise = return (arity_type, rhs) where - mode = getMode env in_scope = getInScope env - dflags = sm_dflags mode - arity_opts = initArityOpts dflags + arity_opts = seArityOpts env old_arity = exprArity rhs arity_type = findRhsArity arity_opts is_rec bndr rhs old_arity new_arity = arityTypeArity arity_type @@ -2399,7 +2352,7 @@ There are some wrinkles -} mkCase, mkCase1, mkCase2, mkCase3 - :: DynFlags + :: SimplMode -> OutExpr -> OutId -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order -> SimplM OutExpr @@ -2408,8 +2361,8 @@ mkCase, mkCase1, mkCase2, mkCase3 -- 1. Merge Nested Cases -------------------------------------------------- -mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) - | gopt Opt_CaseMerge dflags +mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) + | sm_case_merge mode , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) <- stripTicksTop tickishFloatable deflt_rhs , inner_scrut_var == outer_bndr @@ -2436,7 +2389,7 @@ mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) -- precedence over e2 as the value for A! ; fmap (mkTicks ticks) $ - mkCase1 dflags scrut outer_bndr alts_ty merged_alts + mkCase1 mode scrut outer_bndr alts_ty merged_alts } -- Warning: don't call mkCase recursively! -- Firstly, there's no point, because inner alts have already had @@ -2444,13 +2397,13 @@ mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr -- in munge_rhs may put a case into the DEFAULT branch! -mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts +mkCase mode scrut bndr alts_ty alts = mkCase1 mode scrut bndr alts_ty alts -------------------------------------------------- -- 2. Eliminate Identity Case -------------------------------------------------- -mkCase1 _dflags scrut case_bndr _ alts@(Alt _ _ rhs1 : _) -- Identity case +mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : _) -- Identity case | all identity_alt alts = do { tick (CaseIdentity case_bndr) ; return (mkTicks ticks $ re_cast scrut rhs1) } @@ -2489,19 +2442,19 @@ mkCase1 _dflags scrut case_bndr _ alts@(Alt _ _ rhs1 : _) -- Identity case re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co re_cast scrut _ = scrut -mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts +mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts -------------------------------------------------- -- 2. Scrutinee Constant Folding -------------------------------------------------- -mkCase2 dflags scrut bndr alts_ty alts +mkCase2 mode scrut bndr alts_ty alts | -- See Note [Scrutinee Constant Folding] case alts of -- Not if there is just a DEFAULT alternative [Alt DEFAULT _ _] -> False _ -> True - , gopt Opt_CaseFolding dflags - , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut + , sm_case_folding mode + , Just (scrut', tx_con, mk_orig) <- caseRules (smPlatform mode) scrut = do { bndr' <- newId (fsLit "lwild") Many (exprType scrut') ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts @@ -2509,12 +2462,12 @@ mkCase2 dflags scrut bndr alts_ty alts -- See Note [Unreachable caseRules alternatives] -- in GHC.Core.Opt.ConstantFold - ; mkCase3 dflags scrut' bndr' alts_ty $ + ; mkCase3 mode scrut' bndr' alts_ty $ add_default (re_sort alts') } | otherwise - = mkCase3 dflags scrut bndr alts_ty alts + = mkCase3 mode scrut bndr alts_ty alts where -- We need to keep the correct association between the scrutinee and its -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with @@ -2595,7 +2548,7 @@ in GHC.Core.Opt.ConstantFold) -------------------------------------------------- -- Catch-all -------------------------------------------------- -mkCase3 _dflags scrut bndr alts_ty alts +mkCase3 _mode scrut bndr alts_ty alts = return (Case scrut bndr alts_ty alts) -- See Note [Exitification] and Note [Do not inline exit join points] in diff --git a/compiler/GHC/Core/Opt/Stats.hs b/compiler/GHC/Core/Opt/Stats.hs new file mode 100644 index 0000000000..bdf920a8ee --- /dev/null +++ b/compiler/GHC/Core/Opt/Stats.hs @@ -0,0 +1,330 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE DerivingVia #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Core.Opt.Stats ( + SimplCount, doSimplTick, doFreeSimplTick, simplCountN, + pprSimplCount, plusSimplCount, zeroSimplCount, + isZeroSimplCount, hasDetailedCounts, Tick(..) + ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Error + +import GHC.Utils.Outputable as Outputable + +import GHC.Data.FastString + +import Data.List (groupBy, sortBy) +import Data.Ord +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict +import GHC.Utils.Panic (throwGhcException, GhcException(..), panic) + +getVerboseSimplStats :: (Bool -> SDoc) -> SDoc +getVerboseSimplStats = getPprDebug -- For now, anyway + +zeroSimplCount :: Bool -- ^ -ddump-simpl-stats + -> SimplCount +isZeroSimplCount :: SimplCount -> Bool +hasDetailedCounts :: SimplCount -> Bool +pprSimplCount :: SimplCount -> SDoc +doSimplTick :: Int -- ^ History size of the elaborate counter + -> Tick -> SimplCount -> SimplCount +doFreeSimplTick :: Tick -> SimplCount -> SimplCount +plusSimplCount :: SimplCount -> SimplCount -> SimplCount + +data SimplCount + = VerySimplCount !Int -- Used when don't want detailed stats + + | SimplCount { + ticks :: !Int, -- Total ticks + details :: !TickCounts, -- How many of each type + + n_log :: !Int, -- N + log1 :: [Tick], -- Last N events; <= opt_HistorySize, + -- most recent first + log2 :: [Tick] -- Last opt_HistorySize events before that + -- Having log1, log2 lets us accumulate the + -- recent history reasonably efficiently + } + +type TickCounts = Map Tick Int + +simplCountN :: SimplCount -> Int +simplCountN (VerySimplCount n) = n +simplCountN (SimplCount { ticks = n }) = n + +zeroSimplCount dump_simpl_stats + -- This is where we decide whether to do + -- the VerySimpl version or the full-stats version + | dump_simpl_stats + = SimplCount {ticks = 0, details = Map.empty, + n_log = 0, log1 = [], log2 = []} + | otherwise + = VerySimplCount 0 + +isZeroSimplCount (VerySimplCount n) = n==0 +isZeroSimplCount (SimplCount { ticks = n }) = n==0 + +hasDetailedCounts (VerySimplCount {}) = False +hasDetailedCounts (SimplCount {}) = True + +doFreeSimplTick tick sc@SimplCount { details = dts } + = sc { details = dts `addTick` tick } +doFreeSimplTick _ sc = sc + +doSimplTick history_size tick + sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) + | nl >= history_size = sc1 { n_log = 1, log1 = [tick], log2 = l1 } + | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } + where + sc1 = sc { ticks = tks+1, details = dts `addTick` tick } + +doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) + + +addTick :: TickCounts -> Tick -> TickCounts +addTick fm tick = MapStrict.insertWith (+) tick 1 fm + +plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) + sc2@(SimplCount { ticks = tks2, details = dts2 }) + = log_base { ticks = tks1 + tks2 + , details = MapStrict.unionWith (+) dts1 dts2 } + where + -- A hackish way of getting recent log info + log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 + | null (log2 sc2) = sc2 { log2 = log1 sc1 } + | otherwise = sc2 + +plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) +plusSimplCount lhs rhs = + throwGhcException . PprProgramError "plusSimplCount" $ vcat + [ text "lhs" + , pprSimplCount lhs + , text "rhs" + , pprSimplCount rhs + ] + -- We use one or the other consistently + +pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n +pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) + = vcat [text "Total ticks: " <+> int tks, + blankLine, + pprTickCounts dts, + getVerboseSimplStats $ \dbg -> if dbg + then + vcat [blankLine, + text "Log (most recent first)", + nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] + else Outputable.empty + ] + +{- Note [Which transformations are innocuous] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one point (Jun 18) I wondered if some transformations (ticks) +might be "innocuous", in the sense that they do not unlock a later +transformation that does not occur in the same pass. If so, we could +refrain from bumping the overall tick-count for such innocuous +transformations, and perhaps terminate the simplifier one pass +earlier. + +But alas I found that virtually nothing was innocuous! This Note +just records what I learned, in case anyone wants to try again. + +These transformations are not innocuous: + +*** NB: I think these ones could be made innocuous + EtaExpansion + LetFloatFromLet + +LetFloatFromLet + x = K (let z = e2 in Just z) + prepareRhs transforms to + x2 = let z=e2 in Just z + x = K xs + And now more let-floating can happen in the + next pass, on x2 + +PreInlineUnconditionally + Example in spectral/cichelli/Auxil + hinsert = ...let lo = e in + let j = ...lo... in + case x of + False -> () + True -> case lo of I# lo' -> + ...j... + When we PreInlineUnconditionally j, lo's occ-info changes to once, + so it can be PreInlineUnconditionally in the next pass, and a + cascade of further things can happen. + +PostInlineUnconditionally + let x = e in + let y = ...x.. in + case .. of { A -> ...x...y... + B -> ...x...y... } + Current postinlineUnconditinaly will inline y, and then x; sigh. + + But PostInlineUnconditionally might also unlock subsequent + transformations for the same reason as PreInlineUnconditionally, + so it's probably not innocuous anyway. + +KnownBranch, BetaReduction: + May drop chunks of code, and thereby enable PreInlineUnconditionally + for some let-binding which now occurs once + +EtaExpansion: + Example in imaginary/digits-of-e1 + fail = \void. e where e :: IO () + --> etaExpandRhs + fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) + --> Next iteration of simplify + fail1 = \void. \s. (e |> g) s + fail = fail1 |> Void# -> sym g + And now inline 'fail' + +CaseMerge: + case x of y { + DEFAULT -> case y of z { pi -> ei } + alts2 } + ---> CaseMerge + case x of { pi -> let z = y in ei + ; alts2 } + The "let z=y" case-binder-swap gets dealt with in the next pass +-} + +pprTickCounts :: Map Tick Int -> SDoc +pprTickCounts counts + = vcat (map pprTickGroup groups) + where + groups :: [[(Tick,Int)]] -- Each group shares a common tag + -- toList returns common tags adjacent + groups = groupBy same_tag (Map.toList counts) + same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 + +pprTickGroup :: [(Tick, Int)] -> SDoc +pprTickGroup group@((tick1,_):_) + = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) + 2 (vcat [ int n <+> pprTickCts tick + -- flip as we want largest first + | (tick,n) <- sortBy (flip (comparing snd)) group]) +pprTickGroup [] = panic "pprTickGroup" + +data Tick -- See Note [Which transformations are innocuous] + = PreInlineUnconditionally Id + | PostInlineUnconditionally Id + + | UnfoldingDone Id + | RuleFired FastString -- Rule name + + | LetFloatFromLet + | EtaExpansion Id -- LHS binder + | EtaReduction Id -- Binder on outer lambda + | BetaReduction Id -- Lambda binder + + + | CaseOfCase Id -- Bndr on *inner* case + | KnownBranch Id -- Case binder + | CaseMerge Id -- Binder on outer case + | AltMerge Id -- Case binder + | CaseElim Id -- Case binder + | CaseIdentity Id -- Case binder + | FillInCaseDefault Id -- Case binder + + | SimplifierDone -- Ticked at each iteration of the simplifier + +instance Outputable Tick where + ppr tick = text (tickString tick) <+> pprTickCts tick + +instance Eq Tick where + a == b = case a `cmpTick` b of + EQ -> True + _ -> False + +instance Ord Tick where + compare = cmpTick + +tickToTag :: Tick -> Int +tickToTag (PreInlineUnconditionally _) = 0 +tickToTag (PostInlineUnconditionally _) = 1 +tickToTag (UnfoldingDone _) = 2 +tickToTag (RuleFired _) = 3 +tickToTag LetFloatFromLet = 4 +tickToTag (EtaExpansion _) = 5 +tickToTag (EtaReduction _) = 6 +tickToTag (BetaReduction _) = 7 +tickToTag (CaseOfCase _) = 8 +tickToTag (KnownBranch _) = 9 +tickToTag (CaseMerge _) = 10 +tickToTag (CaseElim _) = 11 +tickToTag (CaseIdentity _) = 12 +tickToTag (FillInCaseDefault _) = 13 +tickToTag SimplifierDone = 16 +tickToTag (AltMerge _) = 17 + +tickString :: Tick -> String +tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" +tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" +tickString (UnfoldingDone _) = "UnfoldingDone" +tickString (RuleFired _) = "RuleFired" +tickString LetFloatFromLet = "LetFloatFromLet" +tickString (EtaExpansion _) = "EtaExpansion" +tickString (EtaReduction _) = "EtaReduction" +tickString (BetaReduction _) = "BetaReduction" +tickString (CaseOfCase _) = "CaseOfCase" +tickString (KnownBranch _) = "KnownBranch" +tickString (CaseMerge _) = "CaseMerge" +tickString (AltMerge _) = "AltMerge" +tickString (CaseElim _) = "CaseElim" +tickString (CaseIdentity _) = "CaseIdentity" +tickString (FillInCaseDefault _) = "FillInCaseDefault" +tickString SimplifierDone = "SimplifierDone" + +pprTickCts :: Tick -> SDoc +pprTickCts (PreInlineUnconditionally v) = ppr v +pprTickCts (PostInlineUnconditionally v)= ppr v +pprTickCts (UnfoldingDone v) = ppr v +pprTickCts (RuleFired v) = ppr v +pprTickCts LetFloatFromLet = Outputable.empty +pprTickCts (EtaExpansion v) = ppr v +pprTickCts (EtaReduction v) = ppr v +pprTickCts (BetaReduction v) = ppr v +pprTickCts (CaseOfCase v) = ppr v +pprTickCts (KnownBranch v) = ppr v +pprTickCts (CaseMerge v) = ppr v +pprTickCts (AltMerge v) = ppr v +pprTickCts (CaseElim v) = ppr v +pprTickCts (CaseIdentity v) = ppr v +pprTickCts (FillInCaseDefault v) = ppr v +pprTickCts _ = Outputable.empty + +cmpTick :: Tick -> Tick -> Ordering +cmpTick a b = case (tickToTag a `compare` tickToTag b) of + GT -> GT + EQ -> cmpEqTick a b + LT -> LT + +cmpEqTick :: Tick -> Tick -> Ordering +cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b +cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b +cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b +cmpEqTick (RuleFired a) (RuleFired b) = a `uniqCompareFS` b +cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b +cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b +cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b +cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b +cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b +cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b +cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b +cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b +cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b +cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b +cmpEqTick _ _ = EQ diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 3078d26969..6f02d8e3a2 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -32,8 +32,7 @@ import GHC.Builtin.Types import GHC.Core.Utils import GHC.Core.Opt.Arity -import GHC.Core.Opt.Monad ( CoreToDo(..) ) -import GHC.Core.Lint ( EndPassConfig, endPassIO ) +import GHC.Core.Lint ( EndPassConfig(..), endPassIO ) import GHC.Core import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here import GHC.Core.Type @@ -260,7 +259,7 @@ corePrepPgm logger cp_cfg pgm_cfg return (deFloatTop (floats1 `appendFloats` floats2)) endPassIO logger (cpPgm_endPassConfig pgm_cfg) - alwaysQualify CorePrep binds_out [] + binds_out [] return binds_out corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr 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 diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 0f8ce9fd5b..f816157e10 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -55,7 +55,7 @@ import GHC.Core.Coercion import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make import GHC.Core.Rules -import GHC.Core.Opt.Monad ( CoreToDo(..) ) +import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) import GHC.Core.Ppr import GHC.Builtin.Names diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs index 93220b5eef..6456c9231c 100644 --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -17,6 +17,8 @@ module GHC.Plugins , module GHC.Types.Id.Info , module GHC.Types.PkgQual , module GHC.Core.Opt.Monad + , module GHC.Core.Opt.Pipeline.Types + , module GHC.Core.Opt.Stats , module GHC.Core , module GHC.Types.Literal , module GHC.Core.DataCon @@ -83,6 +85,8 @@ import GHC.Types.Id.Info -- Core import GHC.Core.Opt.Monad +import GHC.Core.Opt.Pipeline.Types +import GHC.Core.Opt.Stats import GHC.Core import GHC.Types.Literal import GHC.Core.DataCon diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 63154a48bd..15586cfce9 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -92,7 +92,6 @@ import GHC.Prelude import GHC.Stg.Syntax import GHC.Stg.Utils -import GHC.Core.Lint ( interactiveInScope ) import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) import GHC.Core.Type @@ -112,7 +111,6 @@ import GHC.Utils.Error ( mkLocMessage, DiagOpts ) import qualified GHC.Utils.Error as Err import GHC.Unit.Module ( Module ) -import GHC.Runtime.Context ( InteractiveContext ) import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) @@ -129,14 +127,14 @@ lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) -> Logger -> DiagOpts -> StgPprOpts - -> InteractiveContext + -> [Var] -- ^ extra vars in scope from GHCi -> Module -- ^ module being compiled -> Bool -- ^ have we run Unarise yet? -> String -- ^ who produced the STG? -> [GenStgTopBinding a] -> IO () -lintStgTopBindings platform logger diag_opts opts ictxt this_mod unarised whodunnit binds +lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised whodunnit binds = {-# SCC "StgLint" #-} case initL platform diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of Nothing -> @@ -155,7 +153,7 @@ lintStgTopBindings platform logger diag_opts opts ictxt this_mod unarised whodun -- Bring all top-level binds into scope because CoreToStg does not generate -- bindings in dependency order (so we may see a use before its definition). top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds)) - (interactiveInScope ictxt) + extra_vars lint_binds :: [GenStgTopBinding a] -> LintM () diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs index f6bf55d398..c5f7bc2da3 100644 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -29,9 +29,9 @@ import GHC.Stg.BcPrep ( bcPrep ) import GHC.Stg.CSE ( stgCse ) import GHC.Stg.Lift ( StgLiftConfig, stgLiftLams ) import GHC.Unit.Module ( Module ) -import GHC.Runtime.Context ( InteractiveContext ) import GHC.Utils.Error +import GHC.Types.Var import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Utils.Logger @@ -62,12 +62,12 @@ runStgM :: Char -> StgM a -> IO a runStgM mask (StgM m) = runReaderT m mask stg2stg :: Logger - -> InteractiveContext + -> [Var] -- ^ extra vars in scope from GHCi -> StgPipelineOpts - -> Module -- module being compiled - -> [StgTopBinding] -- input program + -> Module -- ^ module being compiled + -> [StgTopBinding] -- ^ input program -> IO [CgStgTopBinding] -- output program -stg2stg logger ictxt opts this_mod binds +stg2stg logger extra_vars opts this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds ; showPass logger "Stg2Stg" -- Do the main business! @@ -94,7 +94,7 @@ stg2stg logger ictxt opts this_mod binds = lintStgTopBindings (stgPlatform opts) logger diag_opts ppr_opts - ictxt this_mod unarised + extra_vars this_mod unarised | otherwise = \ _whodunnit _binds -> return () diff --git a/compiler/GHC/Unit/Env.hs b/compiler/GHC/Unit/Env.hs index c3b7aaed4a..fe5a8e04e4 100644 --- a/compiler/GHC/Unit/Env.hs +++ b/compiler/GHC/Unit/Env.hs @@ -3,6 +3,7 @@ module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv + , ueEPS , unsafeGetHomeUnit , updateHug , updateHpt @@ -98,6 +99,9 @@ data UnitEnv = UnitEnv -- ^ GHC name/version (used for dynamic library suffix) } +ueEPS :: UnitEnv -> IO ExternalPackageState +ueEPS = eucEPS . ue_eps + initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv initUnitEnv cur_unit hug namever platform = do eps <- initExternalUnitCache diff --git a/compiler/GHC/Unit/External.hs b/compiler/GHC/Unit/External.hs index 4ed3479bf4..04af938c03 100644 --- a/compiler/GHC/Unit/External.hs +++ b/compiler/GHC/Unit/External.hs @@ -1,6 +1,7 @@ module GHC.Unit.External ( ExternalUnitCache (..) , initExternalUnitCache + , eucEPS , ExternalPackageState (..) , initExternalPackageState , EpsStats(..) @@ -59,6 +60,9 @@ newtype ExternalUnitCache = ExternalUnitCache initExternalUnitCache :: IO ExternalUnitCache initExternalUnitCache = ExternalUnitCache <$> newIORef initExternalPackageState +eucEPS :: ExternalUnitCache -> IO ExternalPackageState +eucEPS = readIORef . euc_eps + initExternalPackageState :: ExternalPackageState initExternalPackageState = EPS { eps_is_boot = emptyInstalledModuleEnv diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index dc6de716f7..b5d1b8d571 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -298,6 +298,7 @@ Library GHC.Core.FVs GHC.Core.InstEnv GHC.Core.Lint + GHC.Core.Lint.Interactive GHC.Core.LateCC GHC.Core.Make GHC.Core.Map.Expr @@ -317,14 +318,17 @@ Library GHC.Core.Opt.Monad GHC.Core.Opt.OccurAnal GHC.Core.Opt.Pipeline + GHC.Core.Opt.Pipeline.Types GHC.Core.Opt.SetLevels GHC.Core.Opt.Simplify GHC.Core.Opt.Simplify.Env + GHC.Core.Opt.Simplify.Iteration GHC.Core.Opt.Simplify.Monad GHC.Core.Opt.Simplify.Utils GHC.Core.Opt.SpecConstr GHC.Core.Opt.Specialise GHC.Core.Opt.StaticArgs + GHC.Core.Opt.Stats GHC.Core.Opt.WorkWrap GHC.Core.Opt.WorkWrap.Utils GHC.Core.PatSyn @@ -396,8 +400,10 @@ Library GHC.Driver.Config.CmmToAsm GHC.Driver.Config.CmmToLlvm GHC.Driver.Config.Core.Lint + GHC.Driver.Config.Core.Lint.Interactive GHC.Driver.Config.Core.Opt.Arity GHC.Driver.Config.Core.Opt.LiberateCase + GHC.Driver.Config.Core.Opt.Simplify GHC.Driver.Config.Core.Opt.WorkWrap GHC.Driver.Config.Core.Rules GHC.Driver.Config.CoreToStg.Prep diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index 6a7ec5da95..0705d70d75 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -32,6 +32,7 @@ GHC.Core.FVs GHC.Core.FamInstEnv GHC.Core.InstEnv GHC.Core.Lint +GHC.Core.Lint.Interactive GHC.Core.Make GHC.Core.Map.Expr GHC.Core.Map.Type @@ -41,6 +42,13 @@ GHC.Core.Opt.CallerCC GHC.Core.Opt.ConstantFold GHC.Core.Opt.Monad GHC.Core.Opt.OccurAnal +GHC.Core.Opt.Pipeline.Types +GHC.Core.Opt.Simplify +GHC.Core.Opt.Simplify.Env +GHC.Core.Opt.Simplify.Iteration +GHC.Core.Opt.Simplify.Monad +GHC.Core.Opt.Simplify.Utils +GHC.Core.Opt.Stats GHC.Core.PatSyn GHC.Core.Ppr GHC.Core.Predicate diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index ef24b93130..3ab7ace8df 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -32,6 +32,7 @@ GHC.Core.FVs GHC.Core.FamInstEnv GHC.Core.InstEnv GHC.Core.Lint +GHC.Core.Lint.Interactive GHC.Core.Make GHC.Core.Map.Expr GHC.Core.Map.Type @@ -41,6 +42,13 @@ GHC.Core.Opt.CallerCC GHC.Core.Opt.ConstantFold GHC.Core.Opt.Monad GHC.Core.Opt.OccurAnal +GHC.Core.Opt.Pipeline.Types +GHC.Core.Opt.Simplify +GHC.Core.Opt.Simplify.Env +GHC.Core.Opt.Simplify.Iteration +GHC.Core.Opt.Simplify.Monad +GHC.Core.Opt.Simplify.Utils +GHC.Core.Opt.Stats GHC.Core.PatSyn GHC.Core.Ppr GHC.Core.Predicate diff --git a/testsuite/tests/linters/notes.stdout b/testsuite/tests/linters/notes.stdout index 3f5c1ae0b9..c8a9278989 100644 --- a/testsuite/tests/linters/notes.stdout +++ b/testsuite/tests/linters/notes.stdout @@ -1,9 +1,9 @@ ref compiler/GHC/Core/Coercion/Axiom.hs:458:2: Note [RoughMap and rm_empty] ref compiler/GHC/Core/Opt/OccurAnal.hs:857:15: Note [Loop breaking] ref compiler/GHC/Core/Opt/SetLevels.hs:1598:30: Note [Top level scope] -ref compiler/GHC/Core/Opt/Simplify.hs:2666:13: Note [Case binder next] -ref compiler/GHC/Core/Opt/Simplify.hs:3288:0: Note [Suppressing binder-swaps on linear case] -ref compiler/GHC/Core/Opt/Simplify.hs:3816:8: Note [Lambda-bound unfoldings] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2666:13: Note [Case binder next] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:3288:0: Note [Suppressing binder-swaps on linear case] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:3816:8: Note [Lambda-bound unfoldings] ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1282:37: Note [Gentle mode] ref compiler/GHC/Core/Opt/Specialise.hs:1611:28: Note [Arity decrease] ref compiler/GHC/Core/TyCo/Rep.hs:1748:31: Note [What prevents a constraint from floating] |