getEnclosingCC, setEnclosingCC,
-- Environments
- SimplEnv, emptySimplEnv, getSubst, setSubst,
- getSubstEnv, extendSubst, extendSubstList,
- getInScope, setInScope, modifyInScope, addNewInScopeIds,
- setSubstEnv, zapSubstEnv,
+ SimplEnv, emptySimplEnv, getSubst, setSubst, extendIdSubst, extendTvSubst,
+ zapSubstEnv, setSubstEnv, getTvSubst, setTvSubstEnv,
+ getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
-- Floats
Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
import CostCentre ( CostCentreStack, subsumedCCS )
import Var
import VarEnv
-import VarSet
import OrdList
import qualified Subst
-import Subst ( Subst, mkSubst, substEnv,
- InScopeSet, mkInScopeSet, substInScope,
- isInScope
- )
-import Type ( Type, isUnLiftedType )
+import Subst ( Subst, SubstResult, emptySubst, substInScope, isInScope )
+import Type ( Type, TvSubst, TvSubstEnv, isUnLiftedType )
import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
UniqSupply
)
import FiniteMap
-import BasicTypes ( TopLevelFlag, isTopLevel,
+import BasicTypes ( TopLevelFlag, isTopLevel, isLoopBreaker,
Activation, isActive, isAlwaysActive,
- OccInfo(..)
+ OccInfo(..), isOneOcc
)
import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..),
DynFlags, DynFlag(..), dopt,
- opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining,
+ opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining, opt_RulesOff
)
import Unique ( Unique )
-import Maybes ( expectJust )
import Outputable
-import Array ( array, (//) )
import FastTypes
-import GlaExts ( indexArray# )
+import FastString
+import Maybes ( expectJust )
-#if __GLASGOW_HASKELL__ < 301
-import ArrBase ( Array(..) )
-#else
+import GLAEXTS ( indexArray# )
+
+#if __GLASGOW_HASKELL__ < 503
import PrelArr ( Array(..) )
+#else
+import GHC.Arr ( Array(..) )
#endif
+import Array ( array, (//) )
+
infixr 0 `thenSmpl`, `thenSmpl_`
\end{code}
unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
-- A single non-rec float; extend the in-scope set
unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
- (Subst.extendInScopeSet (getInScope env) var)
+ (extendInScopeSet (getInScope env) var)
(not (isUnLiftedType (idType var)))
addFloats :: SimplEnv -> Floats
| PostInlineUnconditionally Id
| UnfoldingDone Id
- | RuleFired FAST_STRING -- Rule name
+ | RuleFired FastString -- Rule name
| LetFloatFromLet
| EtaExpansion Id -- LHS binder
-- have a correctly-substituted type. So we use a lookup in this
-- set to replace occurrences
-emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> VarSet -> SimplEnv
-emptySimplEnv mode switches in_scope
- = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS, seMode = mode,
- seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
+emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> SimplEnv
+emptySimplEnv mode switches
+ = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS,
+ seMode = mode, seSubst = emptySubst }
-- The top level "enclosing CC" is "SUBSUMED".
---------------------
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}
-extendSubst :: SimplEnv -> CoreBndr -> SubstResult -> SimplEnv
-extendSubst env@(SimplEnv {seSubst = subst}) var res
- = env {seSubst = Subst.extendSubst subst var res}
+extendIdSubst :: SimplEnv -> Id -> SubstResult -> SimplEnv
+extendIdSubst env@(SimplEnv {seSubst = subst}) var res
+ = env {seSubst = Subst.extendIdSubst subst var res}
-extendSubstList :: SimplEnv -> [CoreBndr] -> [SubstResult] -> SimplEnv
-extendSubstList env@(SimplEnv {seSubst = subst}) vars ress
- = env {seSubst = Subst.extendSubstList subst vars ress}
+extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
+extendTvSubst env@(SimplEnv {seSubst = subst}) var res
+ = env {seSubst = Subst.extendTvSubst subst var res}
---------------------
getInScope :: SimplEnv -> InScopeSet
setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope
- = env {seSubst = Subst.setInScope 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.extendNewInScopeList 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'}
---------------------
-getSubstEnv :: SimplEnv -> SubstEnv
-getSubstEnv env = substEnv (seSubst env)
-
-setSubstEnv :: SimplEnv -> SubstEnv -> SimplEnv
-setSubstEnv env@(SimplEnv {seSubst = subst}) senv
- = env {seSubst = Subst.setSubstEnv subst senv}
-
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}
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
==> ...(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.
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.
+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
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 = False
+ | 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
+-- 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)
--- We'll have to see
+-- 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
-- Not inside a lambda, one occurrence ==> safe!
other -> False
where
- active = case getMode env of
+ phase = getMode env
+ active = case phase of
SimplGently -> isAlwaysActive prag
SimplPhase n -> isActive n prag
prag = idInlinePragma bndr
story for now.
\begin{code}
-postInlineUnconditionally :: SimplEnv -> OutId -> Bool -> OutExpr -> Bool
-postInlineUnconditionally env bndr loop_breaker rhs
+postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
+postInlineUnconditionally env bndr occ_info rhs
= exprIsTrivial rhs
&& active
- && not loop_breaker
+ && not (isLoopBreaker occ_info)
&& not (isExportedId bndr)
+ -- We used to have (isOneOcc occ_info) instead of
+ -- not (isLoopBreaker occ_info) && not (isExportedId bndr)
+ -- That was because a rather fragile use of rules got confused
+ -- if you inlined even a binding f=g e.g. We used to have
+ -- map = mapList
+ -- But now a more precise use of phases has eliminated this problem,
+ -- so the is_active test will do the job. I think.
+ --
+ -- OLD COMMENT: (delete soon)
+ -- Indeed, you might suppose that
+ -- there is nothing wrong with substituting for a trivial RHS, even
+ -- if it occurs many times. But consider
+ -- x = y
+ -- h = _inline_me_ (...x...)
+ -- Here we do *not* want to have x inlined, even though the RHS is
+ -- trivial, becuase the contract for an INLINE pragma is "no inlining".
+ -- This is important in the rules for the Prelude
where
active = case getMode env of
SimplGently -> isAlwaysActive prag
SimplPhase n -> isActive n prag
prag = idInlinePragma bndr
-\end{code}
-
-blackListInline tells if we must not inline at a call site because the
-Id's inline pragma says not to do so.
-
-However, blackListInline is ignored for things with with Compulsory inlinings,
-because they don't have bindings, so we must inline them no matter how
-gentle we are being.
-\begin{code}
activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
activeInline env id occ
= case getMode env of
- SimplGently -> isAlwaysActive prag && isOneOcc occ
+ SimplGently -> isOneOcc occ && isAlwaysActive prag
-- No inlining at all when doing gentle stuff,
- -- except for things that occur once
+ -- except for local things that occur once
-- The reason is that too little clean-up happens if you
-- don't inline use-once things. Also a bit of inlining is *good* for
-- full laziness; it can expose constant sub-expressions.
where
prag = idInlinePragma id
--- Belongs in BasicTypes; this frag occurs in OccurAnal too
-isOneOcc (OneOcc _ _) = True
-isOneOcc other = False
-
activeRule :: SimplEnv -> Maybe (Activation -> Bool)
-- Nothing => No rules at all
activeRule env
+ | opt_RulesOff = Nothing
+ | otherwise
= case getMode env of
- SimplGently -> Nothing -- No rules in gentle mode
+ SimplGently -> Just isAlwaysActive
+ -- Used to be Nothing (no rules in gentle mode)
+ -- Main motivation for changing is that I wanted
+ -- lift String ===> ...
+ -- to work in Template Haskell when simplifying
+ -- splices, so we get simpler code for literal strings
SimplPhase n -> Just (isActive n)
\end{code}
data SwitchResult
= SwBool Bool -- on/off
- | SwString FAST_STRING -- nothing or a String
+ | SwString FastString -- nothing or a String
| SwInt Int -- nothing or an Int
isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
defined_elems = map mk_assoc_elem tidied_on_switches
in
-- (avoid some unboxing, bounds checking, and other horrible things:)
-#if __GLASGOW_HASKELL__ < 405
- case sw_tbl of { Array bounds_who_needs_'em stuff ->
-#else
case sw_tbl of { Array _ _ stuff ->
-#endif
\ switch ->
case (indexArray# stuff (tagOf_SimplSwitch switch)) of
-#if __GLASGOW_HASKELL__ < 400
- Lift v -> v
-#elif __GLASGOW_HASKELL__ < 403
- (# _, v #) -> v
-#else
(# v #) -> v
-#endif
}
where
mk_assoc_elem k@(MaxSimplifierIterations lvl)
projects / ghc-hetmet.git / blobdiff