+ | 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
+
+ | BottomFound
+ | SimplifierDone -- Ticked at each iteration of the simplifier
+
+isRuleFired (RuleFired _) = True
+isRuleFired other = False
+
+instance Outputable Tick where
+ ppr tick = text (tickString tick) <+> pprTickCts tick
+
+instance Eq Tick where
+ a == b = case a `cmpTick` b of { EQ -> True; other -> 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 BottomFound = 14
+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 BottomFound = "BottomFound"
+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 = 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 other = empty
+
+cmpTick :: Tick -> Tick -> Ordering
+cmpTick a b = case (tickToTag a `compare` tickToTag b) of
+ GT -> GT
+ EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
+ | otherwise -> EQ
+ LT -> LT
+ -- Always distinguish RuleFired, so that the stats
+ -- can report them even in non-verbose mode
+
+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 `compare` 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 other1 other2 = EQ
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsubsection{The @SimplEnv@ type}
+%* *
+%************************************************************************
+
+
+\begin{code}
+data SimplEnv
+ = SimplEnv {
+ seMode :: SimplifierMode,
+ seChkr :: SwitchChecker,
+ seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
+ seSubst :: Subst -- The current substitution
+ }
+ -- The range of the substitution is OutType and OutExpr resp
+ --
+ -- The substitution is idempotent
+ -- It *must* be applied; things in its domain simply aren't
+ -- bound in the result.
+ --
+ -- The substitution usually maps an Id to its clone,
+ -- but if the orig defn is a let-binding, and
+ -- the RHS of the let simplifies to an atom,
+ -- we just add the binding to the substitution and elide the let.
+
+ -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
+ -- The elements of the set may have better IdInfo than the
+ -- occurrences of in-scope Ids, and (more important) they will
+ -- have a correctly-substituted type. So we use a lookup in this
+ -- set to replace occurrences
+
+emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> SimplEnv
+emptySimplEnv mode switches
+ = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS,
+ seMode = mode, seSubst = emptySubst }
+ -- The top level "enclosing CC" is "SUBSUMED".
+
+---------------------
+getSwitchChecker :: SimplEnv -> SwitchChecker
+getSwitchChecker env = seChkr env
+
+---------------------
+getMode :: SimplEnv -> SimplifierMode
+getMode env = seMode env
+
+setMode :: SimplifierMode -> SimplEnv -> SimplEnv
+setMode mode env = env { seMode = mode }
+
+---------------------
+getEnclosingCC :: SimplEnv -> CostCentreStack
+getEnclosingCC env = seCC env
+
+setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
+setEnclosingCC env cc = env {seCC = cc}
+
+---------------------
+getSubst :: SimplEnv -> Subst
+getSubst env = seSubst env
+
+getTvSubst :: SimplEnv -> TvSubst
+getTvSubst env = Subst.getTvSubst (seSubst env)
+
+setTvSubstEnv :: SimplEnv -> TvSubstEnv -> SimplEnv
+setTvSubstEnv env@(SimplEnv {seSubst = subst}) tv_subst_env
+ = env {seSubst = Subst.setTvSubstEnv subst tv_subst_env}
+
+setSubst :: SimplEnv -> Subst -> SimplEnv
+setSubst env subst = env {seSubst = subst}
+
+extendIdSubst :: SimplEnv -> Id -> SubstResult -> SimplEnv
+extendIdSubst env@(SimplEnv {seSubst = subst}) var res
+ = env {seSubst = Subst.extendIdSubst subst var res}
+
+extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
+extendTvSubst env@(SimplEnv {seSubst = subst}) var res
+ = env {seSubst = Subst.extendTvSubst subst var res}
+
+---------------------
+getInScope :: SimplEnv -> InScopeSet
+getInScope env = substInScope (seSubst env)
+
+setInScope :: SimplEnv -> SimplEnv -> SimplEnv
+setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
+
+setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
+setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope
+ = env {seSubst = Subst.setInScopeSet subst in_scope}
+
+addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
+ -- The new Ids are guaranteed to be freshly allocated
+addNewInScopeIds env@(SimplEnv {seSubst = subst}) vs
+ = env {seSubst = Subst.extendInScopeIds subst vs}
+
+modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
+modifyInScope env@(SimplEnv {seSubst = subst}) v v'
+ = env {seSubst = Subst.modifyInScope subst v v'}
+
+---------------------
+zapSubstEnv :: SimplEnv -> SimplEnv
+zapSubstEnv env@(SimplEnv {seSubst = subst})
+ = env {seSubst = Subst.zapSubstEnv subst}
+
+setSubstEnv :: SimplEnv -> Subst -> SimplEnv
+setSubstEnv env@(SimplEnv {seSubst = subst}) subst_with_env
+ = env {seSubst = Subst.setSubstEnv subst subst_with_env}
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Decisions about inlining}
+%* *
+%************************************************************************
+
+Inlining is controlled partly by the SimplifierMode switch. This has two
+settings:
+
+ SimplGently (a) Simplifying before specialiser/full laziness
+ (b) Simplifiying inside INLINE pragma
+ (c) Simplifying the LHS of a rule
+ (d) Simplifying a GHCi expression or Template
+ Haskell splice
+
+ SimplPhase n Used at all other times
+
+The key thing about SimplGently is that it does no call-site inlining.
+Before full laziness we must be careful not to inline wrappers,
+because doing so inhibits floating
+ e.g. ...(case f x of ...)...
+ ==> ...(case (case x of I# x# -> fw x#) of ...)...
+ ==> ...(case x of I# x# -> case fw x# of ...)...
+and now the redex (f x) isn't floatable any more.
+
+The no-inling thing is also important for Template Haskell. You might be
+compiling in one-shot mode with -O2; but when TH compiles a splice before
+running it, we don't want to use -O2. Indeed, we don't want to inline
+anything, because the byte-code interpreter might get confused about
+unboxed tuples and suchlike.
+
+INLINE pragmas
+~~~~~~~~~~~~~~
+SimplGently is also used as the mode to simplify inside an InlineMe note.
+
+\begin{code}
+inlineMode :: SimplifierMode
+inlineMode = SimplGently
+\end{code}
+
+It really is important to switch off inlinings inside such
+expressions. Consider the following example
+
+ let f = \pq -> BIG
+ in
+ let g = \y -> f y y
+ {-# INLINE g #-}
+ in ...g...g...g...g...g...
+
+Now, if that's the ONLY occurrence of f, it will be inlined inside g,
+and thence copied multiple times when g is inlined.
+
+
+This function may be inlinined in other modules, so we
+don't want to remove (by inlining) calls to functions that have
+specialisations, or that may have transformation rules in an importing
+scope.
+
+E.g. {-# INLINE f #-}
+ f x = ...g...
+
+and suppose that g is strict *and* has specialisations. If we inline
+g's wrapper, we deny f the chance of getting the specialised version
+of g when f is inlined at some call site (perhaps in some other
+module).
+
+It's also important not to inline a worker back into a wrapper.
+A wrapper looks like
+ wraper = inline_me (\x -> ...worker... )
+Normally, the inline_me prevents the worker getting inlined into
+the wrapper (initially, the worker's only call site!). But,
+if the wrapper is sure to be called, the strictness analyser will
+mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
+continuation. That's why the keep_inline predicate returns True for
+ArgOf continuations. It shouldn't do any harm not to dissolve the
+inline-me note under these circumstances.
+
+Note that the result is that we do very little simplification
+inside an InlineMe.
+
+ all xs = foldr (&&) True xs
+ any p = all . map p {-# INLINE any #-}
+
+Problem: any won't get deforested, and so if it's exported and the
+importer doesn't use the inlining, (eg passes it as an arg) then we
+won't get deforestation at all. We havn't solved this problem yet!
+
+
+preInlineUnconditionally
+~~~~~~~~~~~~~~~~~~~~~~~~
+@preInlineUnconditionally@ examines a bndr to see if it is used just
+once in a completely safe way, so that it is safe to discard the
+binding inline its RHS at the (unique) usage site, REGARDLESS of how
+big the RHS might be. If this is the case we don't simplify the RHS
+first, but just inline it un-simplified.
+
+This is much better than first simplifying a perhaps-huge RHS and then
+inlining and re-simplifying it. Indeed, it can be at least quadratically
+better. Consider
+
+ x1 = e1
+ x2 = e2[x1]
+ x3 = e3[x2]
+ ...etc...
+ xN = eN[xN-1]
+
+We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
+
+NB: we don't even look at the RHS to see if it's trivial
+We might have
+ x = y
+where x is used many times, but this is the unique occurrence of y.
+We should NOT inline x at all its uses, because then we'd do the same
+for y -- aargh! So we must base this pre-rhs-simplification decision
+solely on x's occurrences, not on its rhs.
+
+Evne RHSs labelled InlineMe aren't caught here, because there might be
+no benefit from inlining at the call site.
+
+[Sept 01] Don't unconditionally inline a top-level thing, because that
+can simply make a static thing into something built dynamically. E.g.
+ x = (a,b)
+ main = \s -> h x
+
+[Remember that we treat \s as a one-shot lambda.] No point in
+inlining x unless there is something interesting about the call site.
+
+But watch out: if you aren't careful, some useful foldr/build fusion
+can be lost (most notably in spectral/hartel/parstof) because the
+foldr didn't see the build. Doing the dynamic allocation isn't a big
+deal, in fact, but losing the fusion can be. But the right thing here
+seems to be to do a callSiteInline based on the fact that there is
+something interesting about the call site (it's strict). Hmm. That
+seems a bit fragile.
+
+Conclusion: inline top level things gaily until Phase 0 (the last
+phase), at which point don't.
+
+\begin{code}
+preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
+preInlineUnconditionally env top_lvl bndr
+ | isTopLevel top_lvl, SimplPhase 0 <- phase = False
+-- If we don't have this test, consider
+-- x = length [1,2,3]
+-- The full laziness pass carefully floats all the cons cells to
+-- top level, and preInlineUnconditionally floats them all back in.
+-- Result is (a) static allocation replaced by dynamic allocation
+-- (b) many simplifier iterations because this tickles
+-- a related problem; only one inlining per pass
+--
+-- On the other hand, I have seen cases where top-level fusion is
+-- lost if we don't inline top level thing (e.g. string constants)
+-- Hence the test for phase zero (which is the phase for all the final
+-- simplifications). Until phase zero we take no special notice of
+-- top level things, but then we become more leery about inlining
+-- them.
+
+ | not active = False
+ | opt_SimplNoPreInlining = False
+ | otherwise = case idOccInfo bndr of
+ IAmDead -> True -- Happens in ((\x.1) v)
+ OneOcc in_lam once -> not in_lam && once
+ -- Not inside a lambda, one occurrence ==> safe!
+ other -> False