simplIdWantsToBeINLINEd,
- singleConstructorType, typeOkForCase
+ singleConstructorType, typeOkForCase,
+
+ substSpecEnvRhs
) where
#include "HsVersions.h"
import Id ( idType, isBottomingId, getIdArity,
addInlinePragma, addIdDemandInfo,
idWantsToBeINLINEd, dataConArgTys, Id,
+ lookupIdEnv, delOneFromIdEnv
)
import IdInfo ( ArityInfo(..), DemandInfo )
import Maybes ( maybeToBool )
import SimplEnv
import SimplMonad
import Type ( tyVarsOfType, mkForAllTys, mkTyVarTys, getTyVar_maybe,
- splitAlgTyConApp_maybe, Type
+ splitAlgTyConApp_maybe, instantiateTy, Type
)
import TyCon ( isDataTyCon )
-import TyVar ( elementOfTyVarSet )
+import TyVar ( elementOfTyVarSet, delFromTyVarEnv )
import SrcLoc ( noSrcLoc )
import Util ( isIn, zipWithEqual, panic, assertPanic )
-- currently handle. (ToDo: when return-in-heap is universal we
-- don't need to worry about this.)
\end{code}
+
+
+
+substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
+It exploits the known structure of a SpecEnv's RHS to have fewer
+equations.
+
+\begin{code}
+substSpecEnvRhs te ve rhs
+ = go te ve rhs
+ where
+ go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
+ go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
+ Just (SubstVar v') -> VarArg v'
+ Just (SubstLit l) -> LitArg l
+ Nothing -> VarArg v)
+ go te ve (Var v) = case lookupIdEnv ve v of
+ Just (SubstVar v') -> Var v'
+ Just (SubstLit l) -> Lit l
+ Nothing -> Var v
+
+ -- These equations are a bit half baked, because
+ -- they don't deal properly wih capture.
+ -- But I'm sure it'll never matter... sigh.
+ go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
+ where
+ te' = delFromTyVarEnv te tyvar
+
+ go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
+ where
+ ve' = delOneFromIdEnv ve v
+\end{code}
mkIdWithNewUniq, mkIdWithNewType,
IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv
)
-import SpecEnv ( lookupSpecEnv, substSpecEnv, isEmptySpecEnv )
+import SpecEnv ( lookupSpecEnv )
import OccurAnal ( occurAnalyseGlobalExpr )
import Literal ( isNoRepLit )
import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
-- id1 has its type zapped
id1 | empty_ty_subst = id
| otherwise = mkIdWithNewType id ty'
-
- -- id2 has its SpecEnv zapped
- id2 | isEmptySpecEnv spec_env = id1
- | otherwise = setIdSpecialisation id1 spec_env'
in
if not_in_scope then
-- No need to clone, but we *must* zap any current substitution
-- (\x.e) with id_subst = [x |-> e']
-- Here we must simply zap the substitution for x
let
- env' = setIdEnv env (new_in_scope_ids id2,
+ env' = setIdEnv env (new_in_scope_ids id1,
delOneFromIdEnv id_subst id)
in
- returnSmpl (env', id2)
+ returnSmpl (env', id1)
else
-- Must clone
getUniqueSmpl `thenSmpl` \ uniq ->
let
- id3 = mkIdWithNewUniq id2 uniq
- env' = setIdEnv env (new_in_scope_ids id3,
- addOneToIdEnv id_subst id (SubstVar id3))
+ id2 = mkIdWithNewUniq id1 uniq
+ env' = setIdEnv env (new_in_scope_ids id2,
+ addOneToIdEnv id_subst id (SubstVar id2))
in
- returnSmpl (env', id3)
+ returnSmpl (env', id2)
)
where
((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
ty = idType id
ty' = instantiateTy ty_subst ty
-
- spec_env = getIdSpecialisation id
- spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId])
simplBinders env binders = mapAccumLSmpl simplBinder env binders
simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
\end{code}
-
-substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
-It exploits the known structure of a SpecEnv's RHS to have fewer
-equations.
-
-\begin{code}
-substSpecEnvRhs te ve rhs
- = go te ve rhs
- where
- go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
- go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
- Just (SubstVar v') -> VarArg v'
- Just (SubstLit l) -> LitArg l
- Nothing -> VarArg v)
- go te ve (Var v) = case lookupIdEnv ve v of
- Just (SubstVar v') -> Var v'
- Just (SubstLit l) -> Lit l
- Nothing -> Var v
-
- -- These equations are a bit half baked, because
- -- they don't deal properly wih capture.
- -- But I'm sure it'll never matter... sigh.
- go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
- where
- te' = delFromTyVarEnv te tyvar
-
- go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
- where
- ve' = delOneFromIdEnv ve v
-\end{code}
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import ConFold ( completePrim )
-import CoreUnfold ( Unfolding, mkFormSummary,
+import CoreUnfold ( Unfolding, mkFormSummary, noUnfolding,
exprIsTrivial, whnfOrBottom, inlineUnconditionally,
FormSummary(..)
)
unTagBinders, squashableDictishCcExpr
)
import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd,
- addIdArity, getIdArity,
+ addIdArity, getIdArity, getIdSpecialisation, setIdSpecialisation,
getIdDemandInfo, addIdDemandInfo
)
import Name ( isExported, isLocallyDefined )
import SimplMonad
import SimplVar ( completeVar, simplBinder, simplBinders, simplTyBinder, simplTyBinders )
import SimplUtils
+import SpecEnv ( isEmptySpecEnv, substSpecEnv )
import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys,
mkFunTys, splitAlgTyConApp_maybe,
splitFunTys, splitFunTy_maybe, isUnpointedType
-> InBinder -> OutId -> OutExpr -- Id and RHS
-> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s)
-completeBind env binder@(_,occ_info) new_id new_rhs
- | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
- = (env, new_binds)
-
+completeBind env binder@(old_id,occ_info) new_id new_rhs
| atomic_rhs -- If rhs (after eta reduction) is atomic
&& not (isExported new_id) -- and binder isn't exported
= -- Drop the binding completely
in
(env2, [])
-{- This case is WRONG. It attempts to exploit knowledge that indirections
- are eliminated (by OccurAnal), but they *aren't* for recursive bindings.
- If this case is enabled, then
- rec { local = (a,b)
- global = local
- ... = case global of ...
- }
- never gets simplified
-
- | atomic_rhs -- Rhs is atomic, and new_id is exported
- && case eta'd_rhs of { Var v -> isLocallyDefined v && not (isExported v); other -> False }
- = -- The local variable v will be eliminated next time round
- -- in favour of new_id, so it's a waste to replace all new_id's with v's
- -- this time round.
- -- This case is an optional improvement; saves a simplifier iteration
- (env, [(new_id, eta'd_rhs)])
--}
-
| otherwise -- Non-atomic
+ -- The big deal here is that we simplify the
+ -- SpecEnv of the Id, if any. We used to do that in simplBinders, but
+ -- that didn't work because it didn't take account of the fact that
+ -- one of the mutually recursive group might mention one of the others
+ -- in its SpecEnv
= let
- env1 = extendEnvGivenBinding env occ_info new_id new_rhs
- in
+ id_w_specenv | isEmptySpecEnv spec_env = new_id
+ | otherwise = setIdSpecialisation new_id spec_env'
+
+ env1 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
+ = extendEnvGivenUnfolding env id_w_specenv occ_info noUnfolding
+ -- Still need to record the new_id with its SpecEnv
+
+ | otherwise -- Can inline it
+ = extendEnvGivenBinding env occ_info id_w_specenv new_rhs
+
+ in
(env1, new_binds)
where
+ spec_env = getIdSpecialisation old_id
+ spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
+ (ty_subst,id_subst) = getSubstEnvs env
+
new_binds = [(new_id, new_rhs)]
atomic_rhs = is_atomic eta'd_rhs
eta'd_rhs = case lookForConstructor env new_rhs of
projects / ghc-hetmet.git / commitdiff