SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst,
zapSubstEnv, setSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
- getRules,
+ getRules, refineSimplEnv,
SimplSR(..), mkContEx, substId,
- simplLetBndr, simplLetBndrs, simplLamBndr, simplLamBndrs,
- simplBinder, simplBinders,
- simplIdInfo, substExpr, substTy,
+ simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
+ simplBinder, simplBinders, addLetIdInfo,
+ substExpr, substTy,
-- Floats
FloatsWith, FloatsWithExpr,
#include "HsVersions.h"
import SimplMonad
-import Rules ( RuleBase, emptyRuleBase )
-import Id ( Id, idType, idOccInfo, idInlinePragma, idUnfolding, setIdUnfolding )
+import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
arityInfo, setArityInfo, workerInfo, setWorkerInfo,
- unfoldingInfo, setUnfoldingInfo,
+ unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo,
unknownArity, workerExists
)
import CoreSyn
-import CoreUtils ( needsCaseBinding, exprIsTrivial )
-import PprCore () -- Instances
+import Unify ( TypeRefinement )
+import Rules ( RuleBase )
+import CoreUtils ( needsCaseBinding )
import CostCentre ( CostCentreStack, subsumedCCS )
import Var
import VarEnv
import VarSet ( isEmptyVarSet )
import OrdList
-import qualified CoreSubst ( Subst, mkSubst, substExpr, substRules, substWorker )
+import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker )
import qualified Type ( substTy, substTyVarBndr )
-import Type ( Type, TvSubst(..), TvSubstEnv, isUnLiftedType, seqType, tyVarsOfType )
-import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
- UniqSupply
- )
-import FiniteMap
-import BasicTypes ( TopLevelFlag, isTopLevel, isLoopBreaker,
- Activation, isActive, isAlwaysActive,
- OccInfo(..), isOneOcc, isFragileOcc
- )
-import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..),
- DynFlags, DynFlag(..), dopt,
- opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining, opt_RulesOff
- )
-import Unique ( Unique )
+import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
+ isUnLiftedType, seqType, tyVarsOfType )
+import BasicTypes ( OccInfo(..), isFragileOcc )
+import DynFlags ( SimplifierMode(..) )
import Util ( mapAccumL )
import Outputable
-import FastTypes
-import FastString
-import Maybes ( expectJust )
-
-import GLAEXTS ( indexArray# )
-
-#if __GLASGOW_HASKELL__ < 503
-import PrelArr ( Array(..) )
-#else
-import GHC.Arr ( Array(..) )
-#endif
-
-import Array ( array, (//) )
-
\end{code}
%************************************************************************
-- The new Ids are guaranteed to be freshly allocated
addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
= env { seInScope = in_scope `extendInScopeSetList` vs,
- seIdSubst = id_subst `delVarEnvList` vs } -- Why delete?
+ seIdSubst = id_subst `delVarEnvList` vs }
+ -- Why delete? Consider
+ -- let x = a*b in (x, \x -> x+3)
+ -- We add [x |-> a*b] to the substitution, but we must
+ -- *delete* it from the substitution when going inside
+ -- the (\x -> ...)!
modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
getRules = seExtRules
\end{code}
+ GADT stuff
+
+Given an idempotent substitution, generated by the unifier, use it to
+refine the environment
+
+\begin{code}
+refineSimplEnv :: SimplEnv -> TypeRefinement -> SimplEnv
+-- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes
+refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope })
+ (refine_tv_subst, all_bound_here)
+ = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst,
+ seInScope = in_scope' }
+ where
+ in_scope'
+ | all_bound_here = in_scope
+ -- The tvs are the tyvars bound here. If only they
+ -- are refined, there's no need to do anything
+ | otherwise = mapInScopeSet refine_id in_scope
+
+ refine_id v -- Only refine its type; any rules will get
+ -- refined if they are used (I hope)
+ | isId v = setIdType v (Type.substTy refine_subst (idType v))
+ | otherwise = v
+ refine_subst = TvSubst in_scope refine_tv_subst
+\end{code}
%************************************************************************
%* *
refine v = case lookupInScope in_scope v of
Just v' -> v'
Nothing -> WARN( True, ppr v ) v -- This is an error!
-
\end{code}
These functions are in the monad only so that they can be made strict via seq.
\begin{code}
-simplBinders, simplLamBndrs, simplLetBndrs
+simplBinders, simplLamBndrs
:: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs
simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
-simplLetBndrs env bndrs = mapAccumLSmpl simplLetBndr env bndrs
-------------
simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
simplBinder env bndr
| isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
; seqTyVar tv `seq` return (env', tv) }
- | otherwise = do { let (env', id) = substIdBndr False env env bndr
+ | otherwise = do { let (env', id) = substIdBndr env bndr
; seqId id `seq` return (env', id) }
-------------
-simplLetBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
-simplLetBndr env id = do { let (env', id') = substLetId env id
- ; seqId id' `seq` return (env', id') }
-
--------------
simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
-- Used for lambda binders. These sometimes have unfoldings added by
-- the worker/wrapper pass that must be preserved, becuase they can't
| otherwise = seqId id2 `seq` return (env', id2)
where
old_unf = idUnfolding bndr
- (env', id1) = substIdBndr False env env bndr
+ (env', id1) = substIdBndr env bndr
id2 = id1 `setIdUnfolding` substUnfolding env old_unf
--------------
-seqTyVar :: TyVar -> ()
-seqTyVar b = b `seq` ()
-
-seqId :: Id -> ()
-seqId id = seqType (idType id) `seq`
- idInfo id `seq`
- ()
-\end{code}
-
-\begin{code}
--- substBndr and friends are used when doing expression substitution only
--- In this case we can *preserve* occurrence information, and indeed we *want*
--- to do so else lose useful occ info in rules.
-
-substBndr :: SimplEnv -> Var -> (SimplEnv, Var)
-substBndr subst bndr
- | isTyVar bndr = substTyVarBndr subst bndr
- | otherwise = substIdBndr True {- keep fragile info -} subst subst bndr
-
-substBndrs :: SimplEnv -> [Var] -> (SimplEnv, [Var])
-substBndrs subst bndrs = mapAccumL substBndr subst bndrs
-
-substRecBndrs :: SimplEnv -> [Id] -> (SimplEnv, [Id])
--- Substitute a mutually recursive group
-substRecBndrs subst bndrs
- = (new_subst, new_bndrs)
- where
- -- Here's the reason we need to pass rec_subst to substIdBndr
- (new_subst, new_bndrs) = mapAccumL (substIdBndr True {- keep fragile info -} new_subst)
- subst bndrs
-\end{code}
-
-
-\begin{code}
-substIdBndr :: Bool -- True <=> keep fragile info
- -> SimplEnv -- Substitution to use for the IdInfo
- -> SimplEnv -> Id -- Substitition and Id to transform
- -> (SimplEnv, Id) -- Transformed pair
+--------------
+substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform
+ -> (SimplEnv, Id) -- Transformed pair
-- Returns with:
-- * Unique changed if necessary
-- * Type substituted
-- * Unfolding zapped
-- * Rules, worker, lbvar info all substituted
--- * Occurrence info zapped if is_fragile_occ returns True
+-- * Fragile occurrence info zapped
-- * The in-scope set extended with the returned Id
-- * The substitution extended with a DoneId if unique changed
-- In this case, the var in the DoneId is the same as the
-- var returned
-substIdBndr keep_fragile rec_env
- env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
+substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
old_id
= (env { seInScope = in_scope `extendInScopeSet` new_id,
seIdSubst = new_subst }, new_id)
-- id2 has its type zapped
id2 = substIdType env id1
- -- new_id has the right IdInfo
- -- The lazy-set is because we're in a loop here, with
- -- rec_env, when dealing with a mutually-recursive group
- new_id = maybeModifyIdInfo (substIdInfo keep_fragile rec_env) id2
+ -- new_id has the final IdInfo
+ subst = mkCoreSubst env
+ new_id = maybeModifyIdInfo (substIdInfo subst) id2
-- Extend the substitution if the unique has changed
-- See the notes with substTyVarBndr for the delSubstEnv
= extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id))
| otherwise
= delVarEnv id_subst old_id
+\end{code}
+
+
+\begin{code}
+seqTyVar :: TyVar -> ()
+seqTyVar b = b `seq` ()
+
+seqId :: Id -> ()
+seqId id = seqType (idType id) `seq`
+ idInfo id `seq`
+ ()
+
+seqIds :: [Id] -> ()
+seqIds [] = ()
+seqIds (id:ids) = seqId id `seq` seqIds ids
+\end{code}
+
-substLetId :: SimplEnv -> Id -> (SimplEnv, Id)
--- A variant for let-bound Ids
--- Clone Id if necessary
--- Substitute its type
+%************************************************************************
+%* *
+ Let bindings
+%* *
+%************************************************************************
+
+Simplifying let binders
+~~~~~~~~~~~~~~~~~~~~~~~
+Rename the binders if necessary,
+
+\begin{code}
+simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplNonRecBndr env id
+ = do { let (env1, id1) = substLetIdBndr env id
+ ; seqId id1 `seq` return (env1, id1) }
+
+---------------
+simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
+ = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids
+ ; seqIds ids1 `seq` return (env1, ids1) }
+
+---------------
+substLetIdBndr :: SimplEnv -> InBinder -- Env and binder to transform
+ -> (SimplEnv, OutBinder)
+-- C.f. CoreSubst.substIdBndr
+-- Clone Id if necessary, substitute its type
-- Return an Id with completely zapped IdInfo
--- [A subsequent substIdInfo will restore its IdInfo]
+-- [addLetIdInfo, below, will restore its IdInfo]
-- Augment the subtitution
-- if the unique changed, *or*
-- if there's interesting occurrence info
-substLetId env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
+substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
= (env { seInScope = in_scope `extendInScopeSet` new_id,
seIdSubst = new_subst }, new_id)
where
- old_info = idInfo old_id
- id1 = uniqAway in_scope old_id
- id2 = substIdType env id1
- new_id = setIdInfo id2 vanillaIdInfo
+ id1 = uniqAway in_scope old_id
+ id2 = substIdType env id1
+ new_id = setIdInfo id2 vanillaIdInfo
-- Extend the substitution if the unique has changed,
-- or there's some useful occurrence information
-- See the notes with substTyVarBndr for the delSubstEnv
- occ_info = occInfo old_info
+ occ_info = occInfo (idInfo old_id)
new_subst | new_id /= old_id || isFragileOcc occ_info
= extendVarEnv id_subst old_id (DoneId new_id occ_info)
| otherwise
= delVarEnv id_subst old_id
\end{code}
-
-%************************************************************************
-%* *
- Impedence matching to type substitution
-%* *
-%************************************************************************
+Add IdInfo back onto a let-bound Id
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must transfer the IdInfo of the original binder to the new binder.
+This is crucial, to preserve
+ strictness
+ rules
+ worker info
+etc. To do this we must apply the current substitution,
+which incorporates earlier substitutions in this very letrec group.
+
+NB 1. We do this *before* processing the RHS of the binder, so that
+its substituted rules are visible in its own RHS.
+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.
+
+NB 2: We do not transfer the arity (see Subst.substIdInfo)
+The arity of an Id should not be visible
+in its own RHS, else we eta-reduce
+ f = \x -> f x
+to
+ f = f
+which isn't sound. And it makes the arity in f's IdInfo greater than
+the manifest arity, which isn't good.
+The arity will get added later.
+
+NB 3: It's important that we *do* transer the loop-breaker OccInfo,
+because that's what stops the Id getting inlined infinitely, in the body
+of the letrec.
+
+NB 4: does no harm for non-recursive bindings
+
+NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
+ rec { f = g
+ h = ...
+ RULE h Int = f
+ }
+Here, we'll do postInlineUnconditionally on f, and we must "see" that
+when substituting in h's RULE.
\begin{code}
-substTy :: SimplEnv -> Type -> Type
-substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
- = Type.substTy (TvSubst in_scope tv_env) ty
-
-substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
-substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
- = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
- (TvSubst in_scope' tv_env', tv')
- -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
-
--- When substituting in rules etc we can get CoreSubst to do the work
--- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
--- here. I think the this will not usually result in a lot of work;
--- the substitutions are typically small, and laziness will avoid work in many cases.
-
-mkCoreSubst :: SimplEnv -> CoreSubst.Subst
-mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
- = mk_subst tv_env id_env
+addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder)
+addLetIdInfo env in_id out_id
+ = (modifyInScope env out_id out_id, final_id)
where
- mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
-
- fiddle (DoneEx e) = e
- fiddle (DoneId v occ) = Var v
- fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
-
-substExpr :: SimplEnv -> CoreExpr -> CoreExpr
-substExpr env expr
- | isEmptySimplSubst env = expr
- | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr
-\end{code}
-
-
-%************************************************************************
-%* *
-\section{IdInfo substitution}
-%* *
-%************************************************************************
+ final_id = out_id `setIdInfo` new_info
+ subst = mkCoreSubst env
+ old_info = idInfo in_id
+ new_info = case substIdInfo subst old_info of
+ Nothing -> old_info
+ Just new_info -> new_info
-\begin{code}
-simplIdInfo :: SimplEnv -> IdInfo -> IdInfo
- -- Used by the simplifier to compute new IdInfo for a let(rec) binder,
- -- subsequent to simplLetId having zapped its IdInfo
-simplIdInfo env old_info
- = case substIdInfo False env old_info of
- Just new_info -> new_info
- Nothing -> old_info
-
-substIdInfo :: Bool -- True <=> keep even fragile info
- -> SimplEnv
- -> IdInfo
- -> Maybe IdInfo
--- The keep_fragile flag is True when we are running a simple expression
--- substitution that preserves all structure, so that arity and occurrence
--- info are unaffected. The False state is used more often.
---
+substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
-- Substitute the
-- rules
-- worker info
-- Zap the unfolding
--- If keep_fragile then
--- keep OccInfo
--- keep Arity
--- else
--- keep only 'robust' OccInfo
--- zap Arity
+-- Keep only 'robust' OccInfo
+-- Zap Arity
--
-- Seq'ing on the returned IdInfo is enough to cause all the
-- substitutions to happen completely
-substIdInfo keep_fragile env info
+substIdInfo subst info
| nothing_to_do = Nothing
| otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
`setArityInfo` (if keep_arity then old_arity else unknownArity)
- `setSpecInfo` CoreSubst.substRules subst old_rules
+ `setSpecInfo` CoreSubst.substSpec subst old_rules
`setWorkerInfo` CoreSubst.substWorker subst old_wrkr
`setUnfoldingInfo` noUnfolding)
-- setSpecInfo does a seq
-- setWorkerInfo does a seq
where
- subst = mkCoreSubst env
nothing_to_do = keep_occ && keep_arity &&
- isEmptyCoreRules old_rules &&
+ isEmptySpecInfo old_rules &&
not (workerExists old_wrkr) &&
not (hasUnfolding (unfoldingInfo info))
- keep_occ = keep_fragile || not (isFragileOcc old_occ)
- keep_arity = keep_fragile || old_arity == unknownArity
+ keep_occ = not (isFragileOcc old_occ)
+ keep_arity = old_arity == unknownArity
old_arity = arityInfo info
old_occ = occInfo info
old_rules = specInfo info
%************************************************************************
%* *
+ Impedence matching to type substitution
+%* *
+%************************************************************************
+
+\begin{code}
+substTy :: SimplEnv -> Type -> Type
+substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
+ = Type.substTy (TvSubst in_scope tv_env) ty
+
+substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
+substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
+ = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
+ (TvSubst in_scope' tv_env', tv')
+ -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
+
+-- When substituting in rules etc we can get CoreSubst to do the work
+-- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
+-- here. I think the this will not usually result in a lot of work;
+-- the substitutions are typically small, and laziness will avoid work in many cases.
+
+mkCoreSubst :: SimplEnv -> CoreSubst.Subst
+mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
+ = mk_subst tv_env id_env
+ where
+ mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
+
+ fiddle (DoneEx e) = e
+ fiddle (DoneId v occ) = Var v
+ fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
+
+substExpr :: SimplEnv -> CoreExpr -> CoreExpr
+substExpr env expr
+ | isEmptySimplSubst env = expr
+ | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Floats}
%* *
%************************************************************************