summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDominik Peteler <haskell+gitlab@with-h.at>2022-07-04 23:47:16 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-07-22 08:18:40 -0400
commit9a3e1f316598f7d5072ed4f94437f759352580a5 (patch)
treef9286cb4014b4a1ca9d67afff241b54ca1340a9d
parent81d65f7f358fdbd1d13b89c43fc4cbe3ac82d24b (diff)
downloadhaskell-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`.
-rw-r--r--compiler/GHC/Core/LateCC.hs30
-rw-r--r--compiler/GHC/Core/Lint.hs117
-rw-r--r--compiler/GHC/Core/Lint/Interactive.hs52
-rw-r--r--compiler/GHC/Core/Opt/Monad.hs534
-rw-r--r--compiler/GHC/Core/Opt/Pipeline.hs589
-rw-r--r--compiler/GHC/Core/Opt/Pipeline/Types.hs101
-rw-r--r--compiler/GHC/Core/Opt/Simplify.hs4703
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Env.hs232
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Iteration.hs4325
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Monad.hs103
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Utils.hs143
-rw-r--r--compiler/GHC/Core/Opt/Stats.hs330
-rw-r--r--compiler/GHC/CoreToStg/Prep.hs5
-rw-r--r--compiler/GHC/Driver/Config/Core/Lint.hs98
-rw-r--r--compiler/GHC/Driver/Config/Core/Lint/Interactive.hs35
-rw-r--r--compiler/GHC/Driver/Config/Core/Opt/Simplify.hs92
-rw-r--r--compiler/GHC/Driver/Config/CoreToStg/Prep.hs10
-rw-r--r--compiler/GHC/Driver/Main.hs28
-rw-r--r--compiler/GHC/Driver/Plugins.hs3
-rw-r--r--compiler/GHC/HsToCore.hs2
-rw-r--r--compiler/GHC/Plugins.hs4
-rw-r--r--compiler/GHC/Stg/Lint.hs8
-rw-r--r--compiler/GHC/Stg/Pipeline.hs12
-rw-r--r--compiler/GHC/Unit/Env.hs4
-rw-r--r--compiler/GHC/Unit/External.hs4
-rw-r--r--compiler/ghc.cabal.in6
-rw-r--r--testsuite/tests/count-deps/CountDepsAst.stdout8
-rw-r--r--testsuite/tests/count-deps/CountDepsParser.stdout8
-rw-r--r--testsuite/tests/linters/notes.stdout6
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]