--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[CoreUtils]{Utility functions on @Core@ syntax}
+
+\begin{code}
+module CoreSubst (
+ -- Substitution stuff
+ Subst, TvSubstEnv, IdSubstEnv, InScopeSet,
+
+ substTy, substExpr, substRules, substWorker,
+ lookupIdSubst, lookupTvSubst,
+
+ emptySubst, mkEmptySubst, mkSubst, substInScope, isEmptySubst,
+ extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
+ extendInScope, extendInScopeIds,
+ isInScope,
+
+ -- Binders
+ substBndr, substBndrs, substRecBndrs,
+ cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs
+ ) where
+
+#include "HsVersions.h"
+
+import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
+ CoreRules(..), CoreRule(..),
+ isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding
+ )
+import CoreFVs ( exprFreeVars )
+import CoreUtils ( exprIsTrivial )
+
+import qualified Type ( substTy, substTyVarBndr )
+import Type ( Type, tyVarsOfType, TvSubstEnv, TvSubst(..), mkTyVarTy )
+import VarSet
+import VarEnv
+import Var ( setVarUnique, isId )
+import Id ( idType, setIdType, maybeModifyIdInfo, isLocalId )
+import IdInfo ( IdInfo, specInfo, setSpecInfo,
+ unfoldingInfo, setUnfoldingInfo,
+ WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
+ )
+import Unique ( Unique )
+import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply )
+import Var ( Var, Id, TyVar, isTyVar )
+import Maybes ( orElse )
+import Outputable
+import PprCore () -- Instances
+import Util ( mapAccumL )
+import FastTypes
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Substitutions}
+%* *
+%************************************************************************
+
+\begin{code}
+data Subst
+ = Subst InScopeSet -- Variables in in scope (both Ids and TyVars)
+ IdSubstEnv -- Substitution for Ids
+ TvSubstEnv -- Substitution for TyVars
+
+ -- INVARIANT 1: The (domain of the) in-scope set is a superset
+ -- of the free vars of the range of the substitution
+ -- that might possibly clash with locally-bound variables
+ -- in the thing being substituted in.
+ -- This is what lets us deal with name capture properly
+ -- It's a hard invariant to check...
+ -- There are various ways of causing it to happen:
+ -- - arrange that the in-scope set really is all the things in scope
+ -- - arrange that it's the free vars of the range of the substitution
+ -- - make it empty because all the free vars of the subst are fresh,
+ -- and hence can't possibly clash.a
+ --
+ -- INVARIANT 2: The substitution is apply-once; see notes with
+ -- Types.TvSubstEnv
+
+type IdSubstEnv = IdEnv CoreExpr
+
+----------------------------
+isEmptySubst :: Subst -> Bool
+isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env
+
+emptySubst :: Subst
+emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv
+
+mkEmptySubst :: InScopeSet -> Subst
+mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv
+
+mkSubst :: InScopeSet -> TvSubstEnv -> IdSubstEnv -> Subst
+mkSubst in_scope tvs ids = Subst in_scope ids tvs
+
+-- getTvSubst :: Subst -> TvSubst
+-- getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env
+
+-- getTvSubstEnv :: Subst -> TvSubstEnv
+-- getTvSubstEnv (Subst _ _ tv_env) = tv_env
+--
+-- setTvSubstEnv :: Subst -> TvSubstEnv -> Subst
+-- setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs
+
+substInScope :: Subst -> InScopeSet
+substInScope (Subst in_scope _ _) = in_scope
+
+-- zapSubstEnv :: Subst -> Subst
+-- zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv
+
+-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
+extendIdSubst :: Subst -> Id -> CoreExpr -> Subst
+extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs
+
+extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst
+extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs
+
+extendTvSubst :: Subst -> TyVar -> Type -> Subst
+extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r)
+
+extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
+extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs)
+
+lookupIdSubst :: Subst -> Id -> CoreExpr
+lookupIdSubst (Subst in_scope ids tvs) v
+ | not (isLocalId v) = Var v
+ | otherwise
+ = case lookupVarEnv ids v of {
+ Just e -> e ;
+ Nothing ->
+ case lookupInScope in_scope v of {
+ -- Watch out! Must get the Id from the in-scope set,
+ -- because its type there may differ
+ Just v -> Var v ;
+ Nothing -> WARN( True, ptext SLIT("CoreSubst.lookupIdSubst") <+> ppr v )
+ Var v
+ }}
+
+lookupTvSubst :: Subst -> TyVar -> Type
+lookupTvSubst (Subst _ ids tvs) v = lookupVarEnv tvs v `orElse` mkTyVarTy v
+
+------------------------------
+isInScope :: Var -> Subst -> Bool
+isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
+
+extendInScope :: Subst -> Var -> Subst
+extendInScope (Subst in_scope ids tvs) v
+ = Subst (in_scope `extendInScopeSet` v)
+ (ids `delVarEnv` v) (tvs `delVarEnv` v)
+
+extendInScopeIds :: Subst -> [Id] -> Subst
+extendInScopeIds (Subst in_scope ids tvs) vs
+ = Subst (in_scope `extendInScopeSetList` vs)
+ (ids `delVarEnvList` vs) tvs
+\end{code}
+
+Pretty printing, for debugging only
+
+\begin{code}
+instance Outputable Subst where
+ ppr (Subst in_scope ids tvs)
+ = ptext SLIT("<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
+ $$ ptext SLIT(" IdSubst =") <+> ppr ids
+ $$ ptext SLIT(" TvSubst =") <+> ppr tvs
+ <> char '>'
+\end{code}
+
+
+%************************************************************************
+%* *
+ Substituting expressions
+%* *
+%************************************************************************
+
+\begin{code}
+substExpr :: Subst -> CoreExpr -> CoreExpr
+substExpr subst expr
+ = go expr
+ where
+ go (Var v) = lookupIdSubst subst v
+ go (Type ty) = Type (substTy subst ty)
+ go (Lit lit) = Lit lit
+ go (App fun arg) = App (go fun) (go arg)
+ go (Note note e) = Note (go_note note) (go e)
+ go (Lam bndr body) = Lam bndr' (substExpr subst' body)
+ where
+ (subst', bndr') = substBndr subst bndr
+
+ go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
+ where
+ (subst', bndr') = substBndr subst bndr
+
+ go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
+ where
+ (subst', bndrs') = substRecBndrs subst (map fst pairs)
+ pairs' = bndrs' `zip` rhss'
+ rhss' = map (substExpr subst' . snd) pairs
+
+ go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts)
+ where
+ (subst', bndr') = substBndr subst bndr
+
+ go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
+ where
+ (subst', bndrs') = substBndrs subst bndrs
+
+ go_note (Coerce ty1 ty2) = Coerce (substTy subst ty1) (substTy subst ty2)
+ go_note note = note
+\end{code}
+
+
+%************************************************************************
+%* *
+ Substituting binders
+%* *
+%************************************************************************
+
+Remember that substBndr and friends are used when doing expression
+substitution only. Their only business is substitution, so they
+preserve all IdInfo (suitably substituted). For example, we *want* to
+preserve occ info in rules.
+
+\begin{code}
+substBndr :: Subst -> Var -> (Subst, Var)
+substBndr subst bndr
+ | isTyVar bndr = substTyVarBndr subst bndr
+ | otherwise = substIdBndr subst subst bndr
+
+substBndrs :: Subst -> [Var] -> (Subst, [Var])
+substBndrs subst bndrs = mapAccumL substBndr subst bndrs
+
+substRecBndrs :: Subst -> [Id] -> (Subst, [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 subst_id
+ (new_subst, new_bndrs) = mapAccumL (substIdBndr new_subst) subst bndrs
+\end{code}
+
+
+\begin{code}
+substIdBndr :: Subst -- Substitution to use for the IdInfo
+ -> Subst -> Id -- Substitition and Id to transform
+ -> (Subst, Id) -- Transformed pair
+
+substIdBndr rec_subst subst@(Subst in_scope env tvs) old_id
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+ where
+ id1 = uniqAway in_scope old_id -- id1 is cloned if necessary
+ id2 = substIdType subst id1 -- id2 has its type zapped
+
+ -- new_id has the right IdInfo
+ -- The lazy-set is because we're in a loop here, with
+ -- rec_subst, when dealing with a mutually-recursive group
+ new_id = maybeModifyIdInfo (substIdInfo rec_subst) id2
+
+ -- Extend the substitution if the unique has changed
+ -- See the notes with substTyVarBndr for the delSubstEnv
+ new_env | new_id /= old_id = extendVarEnv env old_id (Var new_id)
+ | otherwise = delVarEnv env old_id
+\end{code}
+
+Now a variant that unconditionally allocates a new unique.
+It also unconditionally zaps the OccInfo.
+
+\begin{code}
+cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id)
+cloneIdBndr subst us old_id
+ = clone_id subst subst (old_id, uniqFromSupply us)
+
+cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
+cloneIdBndrs subst us ids
+ = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us)
+
+cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
+cloneRecIdBndrs subst us ids
+ = (subst', ids')
+ where
+ (subst', ids') = mapAccumL (clone_id subst') subst
+ (ids `zip` uniqsFromSupply us)
+
+-- Just like substIdBndr, except that it always makes a new unique
+-- It is given the unique to use
+clone_id :: Subst -- Substitution for the IdInfo
+ -> Subst -> (Id, Unique) -- Substitition and Id to transform
+ -> (Subst, Id) -- Transformed pair
+
+clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+ where
+ id1 = setVarUnique old_id uniq
+ id2 = substIdType subst id1
+ new_id = maybeModifyIdInfo (substIdInfo rec_subst) id2
+ new_env = extendVarEnv env old_id (Var new_id)
+\end{code}
+
+
+%************************************************************************
+%* *
+ Types
+%* *
+%************************************************************************
+
+For types we just call the corresponding function in Type, but we have
+to repackage the substitution, from a Subst to a TvSubst
+
+\begin{code}
+substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar)
+substTyVarBndr (Subst in_scope id_env tv_env) tv
+ = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
+ (TvSubst in_scope' tv_env', tv')
+ -> (Subst in_scope' id_env tv_env', tv')
+
+substTy :: Subst -> Type -> Type
+substTy (Subst in_scope id_env tv_env) ty
+ = Type.substTy (TvSubst in_scope tv_env) ty
+\end{code}
+
+
+%************************************************************************
+%* *
+\section{IdInfo substitution}
+%* *
+%************************************************************************
+
+\begin{code}
+substIdType :: Subst -> Id -> Id
+substIdType subst@(Subst in_scope id_env tv_env) id
+ | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
+ | otherwise = setIdType id (substTy subst old_ty)
+ -- The tyVarsOfType is cheaper than it looks
+ -- because we cache the free tyvars of the type
+ -- in a Note in the id's type itself
+ where
+ old_ty = idType id
+
+------------------
+substIdInfo :: Subst -> IdInfo -> Maybe IdInfo
+-- Always zaps the unfolding, to save substitution work
+substIdInfo subst info
+ | nothing_to_do = Nothing
+ | otherwise = Just (info `setSpecInfo` substRules subst old_rules
+ `setWorkerInfo` substWorker subst old_wrkr
+ `setUnfoldingInfo` noUnfolding)
+ where
+ old_rules = specInfo info
+ old_wrkr = workerInfo info
+ nothing_to_do = isEmptyCoreRules old_rules &&
+ not (workerExists old_wrkr) &&
+ not (hasUnfolding (unfoldingInfo info))
+
+
+------------------
+substWorker :: Subst -> WorkerInfo -> WorkerInfo
+ -- Seq'ing on the returned WorkerInfo is enough to cause all the
+ -- substitutions to happen completely
+
+substWorker subst NoWorker
+ = NoWorker
+substWorker subst (HasWorker w a)
+ = case lookupIdSubst subst w of
+ Var w1 -> HasWorker w1 a
+ other -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr w )
+ NoWorker -- Worker has got substituted away altogether
+ -- (This can happen if it's trivial,
+ -- via postInlineUnconditionally, hence warning)
+
+------------------
+substRules :: Subst -> CoreRules -> CoreRules
+
+substRules subst rules
+ | isEmptySubst subst = rules
+substRules subst (Rules rules rhs_fvs)
+ = seqRules new_rules `seq` new_rules
+ where
+ new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
+
+ do_subst rule@(BuiltinRule _ _) = rule
+ do_subst (Rule name act tpl_vars lhs_args rhs)
+ = Rule name act tpl_vars'
+ (map (substExpr subst') lhs_args)
+ (substExpr subst' rhs)
+ where
+ (subst', tpl_vars') = substBndrs subst tpl_vars
+
+------------------
+substVarSet subst fvs
+ = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
+ where
+ subst_fv subst fv
+ | isId fv = exprFreeVars (lookupIdSubst subst fv)
+ | otherwise = tyVarsOfType (lookupTvSubst subst fv)
+\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[CoreUtils]{Utility functions on @Core@ syntax}
-
-\begin{code}
-module Subst (
- -- Substitution stuff
- IdSubstEnv, SubstResult(..),
-
- Subst, emptySubst, mkSubst, substInScope, substTy,
- lookupIdSubst, lookupTvSubst, isEmptySubst,
- extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
- zapSubstEnv, setSubstEnv,
- getTvSubst, getTvSubstEnv, setTvSubstEnv,
-
- -- Binders
- simplBndr, simplBndrs, simplLetId, simplLamBndr, simplIdInfo,
- substAndCloneId, substAndCloneIds, substAndCloneRecIds,
-
- setInScope, setInScopeSet,
- extendInScope, extendInScopeIds,
- isInScope, modifyInScope,
-
- -- Expression stuff
- substExpr, substRules, substId
- ) where
-
-#include "HsVersions.h"
-
-import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
- CoreRules(..), CoreRule(..),
- isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding, hasSomeUnfolding,
- Unfolding(..)
- )
-import CoreFVs ( exprFreeVars )
-import CoreUtils ( exprIsTrivial )
-
-import qualified Type ( substTy )
-import Type ( Type, tyVarsOfType, TvSubstEnv, TvSubst(..), substTyVarBndr )
-import VarSet
-import VarEnv
-import Var ( setVarUnique, isId, mustHaveLocalBinding )
-import Id ( idType, idInfo, setIdInfo, setIdType,
- idUnfolding, setIdUnfolding,
- idOccInfo, maybeModifyIdInfo )
-import IdInfo ( IdInfo, vanillaIdInfo,
- occInfo, isFragileOcc, setOccInfo,
- specInfo, setSpecInfo,
- setArityInfo, unknownArity, arityInfo,
- unfoldingInfo, setUnfoldingInfo,
- WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
- )
-import BasicTypes ( OccInfo(..) )
-import Unique ( Unique )
-import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply )
-import Var ( Var, Id, TyVar, isTyVar )
-import Outputable
-import PprCore () -- Instances
-import Util ( mapAccumL )
-import FastTypes
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Substitutions}
-%* *
-%************************************************************************
-
-\begin{code}
-data Subst
- = Subst InScopeSet -- Variables in in scope (both Ids and TyVars)
- IdSubstEnv -- Substitution for Ids
- TvSubstEnv -- Substitution for TyVars
-
- -- INVARIANT 1: The (domain of the) in-scope set is a superset
- -- of the free vars of the range of the substitution
- -- that might possibly clash with locally-bound variables
- -- in the thing being substituted in.
- -- This is what lets us deal with name capture properly
- -- It's a hard invariant to check...
- -- There are various ways of causing it to happen:
- -- - arrange that the in-scope set really is all the things in scope
- -- - arrange that it's the free vars of the range of the substitution
- -- - make it empty because all the free vars of the subst are fresh,
- -- and hence can't possibly clash.a
- --
- -- INVARIANT 2: No variable is both in scope and in the domain of the substitution
- -- Equivalently, the substitution is idempotent
- -- [Sep 2000: Lies, all lies. The substitution now does contain
- -- mappings x77 -> DoneId x77 occ
- -- to record x's occurrence information.]
- -- [Also watch out: the substitution can contain x77 -> DoneEx (Var x77)
- -- Consider let x = case k of I# x77 -> ... in
- -- let y = case k of I# x77 -> ... in ...
- -- and suppose the body is strict in both x and y. Then the simplifier
- -- will pull the first (case k) to the top; so the second (case k) will
- -- cancel out, mapping x77 to, well, x77! But one is an in-Id and the
- -- other is an out-Id. So the substitution is idempotent in the sense
- -- that we *must not* repeatedly apply it.]
-
-
-type IdSubstEnv = IdEnv SubstResult
-
-data SubstResult
- = DoneEx CoreExpr -- Completed term
- | DoneId Id OccInfo -- Completed term variable, with occurrence info;
- -- only used by the simplifier
- | ContEx Subst CoreExpr -- A suspended substitution
-\end{code}
-
-The general plan about the substitution and in-scope set for Ids is as follows
-
-* substId always adds new_id to the in-scope set.
- new_id has a correctly-substituted type, occ info
-
-* substId adds a binding (DoneId new_id occ) to the substitution if
- EITHER the Id's unique has changed
- OR the Id has interesting occurrence information
- So in effect you can only get to interesting occurrence information
- by looking up the *old* Id; it's not really attached to the new id
- at all.
-
- Note, though that the substitution isn't necessarily extended
- if the type changes. Why not? Because of the next point:
-
-* We *always, always* finish by looking up in the in-scope set
- any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
- Reason: so that we never finish up with a "old" Id in the result.
- An old Id might point to an old unfolding and so on... which gives a space leak.
-
- [The DoneEx and DoneVar hits map to "new" stuff.]
-
-* It follows that substExpr must not do a no-op if the substitution is empty.
- substType is free to do so, however.
-
-* When we come to a let-binding (say) we generate new IdInfo, including an
- unfolding, attach it to the binder, and add this newly adorned binder to
- the in-scope set. So all subsequent occurrences of the binder will get mapped
- to the full-adorned binder, which is also the one put in the binding site.
-
-* The in-scope "set" usually maps x->x; we use it simply for its domain.
- But sometimes we have two in-scope Ids that are synomyms, and should
- map to the same target: x->x, y->x. Notably:
- case y of x { ... }
- That's why the "set" is actually a VarEnv Var
-
-
-\begin{code}
-isEmptySubst :: Subst -> Bool
-isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env
-
-emptySubst :: Subst
-emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv
-
-mkSubst :: InScopeSet -> Subst
-mkSubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv
-
-getTvSubst :: Subst -> TvSubst
-getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env
-
-getTvSubstEnv :: Subst -> TvSubstEnv
-getTvSubstEnv (Subst _ _ tv_env) = tv_env
-
-setTvSubstEnv :: Subst -> TvSubstEnv -> Subst
-setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs
-
-
-
-substInScope :: Subst -> InScopeSet
-substInScope (Subst in_scope _ _) = in_scope
-
-zapSubstEnv :: Subst -> Subst
-zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv
-
--- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
-extendIdSubst :: Subst -> Id -> SubstResult -> Subst
-extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs
-
-extendIdSubstList :: Subst -> [(Id, SubstResult)] -> Subst
-extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs
-
-extendTvSubst :: Subst -> TyVar -> Type -> Subst
-extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r)
-
-extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
-extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs)
-
-lookupIdSubst :: Subst -> Id -> Maybe SubstResult
-lookupIdSubst (Subst in_scope ids tvs) v = lookupVarEnv ids v
-
-lookupTvSubst :: Subst -> TyVar -> Maybe Type
-lookupTvSubst (Subst _ ids tvs) v = lookupVarEnv tvs v
-
-------------------------------
-isInScope :: Var -> Subst -> Bool
-isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
-
-modifyInScope :: Subst -> Var -> Var -> Subst
-modifyInScope (Subst in_scope ids tvs) old_v new_v
- = Subst (modifyInScopeSet in_scope old_v new_v) ids tvs
- -- make old_v map to new_v
-
-extendInScope :: Subst -> Var -> Subst
-extendInScope (Subst in_scope ids tvs) v
- = Subst (in_scope `extendInScopeSet` v)
- (ids `delVarEnv` v) (tvs `delVarEnv` v)
-
-extendInScopeIds :: Subst -> [Id] -> Subst
-extendInScopeIds (Subst in_scope ids tvs) vs
- = Subst (in_scope `extendInScopeSetList` vs)
- (ids `delVarEnvList` vs) tvs
-
--------------------------------
-setInScopeSet :: Subst -> InScopeSet -> Subst
-setInScopeSet (Subst _ ids tvs) in_scope
- = Subst in_scope ids tvs
-
-setInScope :: Subst -- Take env part from here
- -> Subst -- Take in-scope part from here
- -> Subst
-setInScope (Subst _ ids tvs) (Subst in_scope _ _)
- = Subst in_scope ids tvs
-
-setSubstEnv :: Subst -- Take in-scope part from here
- -> Subst -- ... and env part from here
- -> Subst
-setSubstEnv s1 s2 = setInScope s2 s1
-\end{code}
-
-Pretty printing, for debugging only
-
-\begin{code}
-instance Outputable SubstResult where
- ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
- ppr (DoneId v _) = ptext SLIT("DoneId") <+> ppr v
- ppr (ContEx _ e) = ptext SLIT("ContEx") <+> ppr e
-
-instance Outputable Subst where
- ppr (Subst in_scope ids tvs)
- = ptext SLIT("<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
- $$ ptext SLIT(" IdSubst =") <+> ppr ids
- $$ ptext SLIT(" TvSubst =") <+> ppr tvs
- <> char '>'
-\end{code}
-
-
-%************************************************************************
-%* *
-\section{Expression substitution}
-%* *
-%************************************************************************
-
-This expression substituter deals correctly with name capture.
-
-BUT NOTE that substExpr silently discards the
- unfolding, and
- spec env
-IdInfo attached to any binders in the expression. It's quite
-tricky to do them 'right' in the case of mutually recursive bindings,
-and so far has proved unnecessary.
-
-\begin{code}
-substExpr :: Subst -> CoreExpr -> CoreExpr
-substExpr subst expr
- -- NB: we do not do a no-op when the substitution is empty,
- -- because we always want to substitute the variables in the
- -- in-scope set for their occurrences. Why?
- -- (a) because they may contain more information
- -- (b) because leaving an un-substituted Id might cause
- -- a space leak (its unfolding might point to an old version
- -- of its right hand side).
-
- = go expr
- where
- go (Var v) = case substId subst v of
- ContEx env' e' -> substExpr (setSubstEnv subst env') e'
- DoneId v _ -> Var v
- DoneEx e' -> e'
-
- go (Type ty) = Type (go_ty ty)
- go (Lit lit) = Lit lit
- go (App fun arg) = App (go fun) (go arg)
- go (Note note e) = Note (go_note note) (go e)
-
- go (Lam bndr body) = Lam bndr' (substExpr subst' body)
- where
- (subst', bndr') = substBndr subst bndr
-
- go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
- where
- (subst', bndr') = substBndr subst bndr
-
- go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
- where
- (subst', bndrs') = substRecBndrs subst (map fst pairs)
- pairs' = bndrs' `zip` rhss'
- rhss' = map (substExpr subst' . snd) pairs
- go (Case scrut bndr ty alts) = Case (go scrut) bndr' (go_ty ty) (map (go_alt subst') alts)
- where
- (subst', bndr') = substBndr subst bndr
-
- go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
- where
- (subst', bndrs') = substBndrs subst bndrs
-
- go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
- go_note note = note
-
- go_ty ty = substTy subst ty
-
-substId :: Subst -> Id -> SubstResult
-substId (Subst in_scope ids tvs) v
- = case lookupVarEnv ids v of
- Just (DoneId v occ) -> DoneId (lookup v) occ
- Just res -> res
- Nothing -> let v' = lookup v
- in DoneId v' (idOccInfo v')
- -- Note [idOccInfo]
- -- We don't use DoneId for LoopBreakers, so the idOccInfo is
- -- very important! If isFragileOcc returned True for
- -- loop breakers we could avoid this call, but at the expense
- -- of adding more to the substitution, and building new Ids
- -- in substId a bit more often than really necessary
- where
- -- Get the most up-to-date thing from the in-scope set
- -- Even though it isn't in the substitution, it may be in
- -- the in-scope set with a different type (we only use the
- -- substitution if the unique changes).
- lookup v = case lookupInScope in_scope v of
- Just v' -> v'
- Nothing -> WARN( mustHaveLocalBinding v, ppr v ) v
-
-
-substTy :: Subst -> Type -> Type
-substTy subst ty = Type.substTy (getTvSubst subst) ty
-\end{code}
-
-
-%************************************************************************
-%* *
-\section{Substituting an Id binder}
-%* *
-%************************************************************************
-
-\begin{code}
--- simplBndr and simplLetId are used by the simplifier
-
-simplBndr :: Subst -> Var -> (Subst, Var)
--- Used for lambda and case-bound variables
--- Clone Id if necessary, substitute type
--- Return with IdInfo already substituted, but (fragile) occurrence info zapped
--- The substitution is extended only if the variable is cloned, because
--- we *don't* need to use it to track occurrence info.
-simplBndr subst bndr
- | isTyVar bndr = subst_tv subst bndr
- | otherwise = subst_id False subst subst bndr
-
-simplBndrs :: Subst -> [Var] -> (Subst, [Var])
-simplBndrs subst bndrs = mapAccumL simplBndr subst bndrs
-
-simplLamBndr :: Subst -> Var -> (Subst, Var)
--- Used for lambda binders. These sometimes have unfoldings added by
--- the worker/wrapper pass that must be preserved, becuase they can't
--- be reconstructed from context. For example:
--- f x = case x of (a,b) -> fw a b x
--- fw a b x{=(a,b)} = ...
--- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
-simplLamBndr subst bndr
- | not (isId bndr && hasSomeUnfolding old_unf)
- = simplBndr subst bndr -- Normal case
- | otherwise
- = (subst', bndr' `setIdUnfolding` substUnfolding subst old_unf)
- where
- old_unf = idUnfolding bndr
- (subst', bndr') = subst_id False subst subst bndr
-
-
-simplLetId :: Subst -> Id -> (Subst, Id)
--- Clone Id if necessary
--- Substitute its type
--- Return an Id with completely zapped IdInfo
--- [A subsequent substIdInfo will restore its IdInfo]
--- Augment the subtitution
--- if the unique changed, *or*
--- if there's interesting occurrence info
-
-simplLetId subst@(Subst in_scope env tvs) old_id
- = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
- where
- old_info = idInfo old_id
- id1 = uniqAway in_scope old_id
- id2 = substIdType subst 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
- new_env | new_id /= old_id || isFragileOcc occ_info
- = extendVarEnv env old_id (DoneId new_id occ_info)
- | otherwise
- = delVarEnv env old_id
-
-simplIdInfo :: Subst -> IdInfo -> IdInfo
- -- Used by the simplifier to compute new IdInfo for a let(rec) binder,
- -- subsequent to simplLetId having zapped its IdInfo
-simplIdInfo subst old_info
- = case substIdInfo False subst old_info of
- Just new_info -> new_info
- Nothing -> old_info
-\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 :: Subst -> Var -> (Subst, Var)
-substBndr subst bndr
- | isTyVar bndr = subst_tv subst bndr
- | otherwise = subst_id True {- keep fragile info -} subst subst bndr
-
-substBndrs :: Subst -> [Var] -> (Subst, [Var])
-substBndrs subst bndrs = mapAccumL substBndr subst bndrs
-
-substRecBndrs :: Subst -> [Id] -> (Subst, [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 subst_id
- (new_subst, new_bndrs) = mapAccumL (subst_id True {- keep fragile info -} new_subst)
- subst bndrs
-\end{code}
-
-
-\begin{code}
-subst_tv :: Subst -> TyVar -> (Subst, TyVar)
--- Unpackage and re-package for substTyVarBndr
-subst_tv (Subst in_scope id_env tv_env) tv
- = case substTyVarBndr (TvSubst in_scope tv_env) tv of
- (TvSubst in_scope' tv_env', tv')
- -> (Subst in_scope' id_env tv_env', tv')
-
-subst_id :: Bool -- True <=> keep fragile info
- -> Subst -- Substitution to use for the IdInfo
- -> Subst -> Id -- Substitition and Id to transform
- -> (Subst, 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
--- * 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
-
-subst_id keep_fragile rec_subst subst@(Subst in_scope env tvs) old_id
- = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
- where
- -- id1 is cloned if necessary
- id1 = uniqAway in_scope old_id
-
- -- id2 has its type zapped
- id2 = substIdType subst id1
-
- -- new_id has the right IdInfo
- -- The lazy-set is because we're in a loop here, with
- -- rec_subst, when dealing with a mutually-recursive group
- new_id = maybeModifyIdInfo (substIdInfo keep_fragile rec_subst) id2
-
- -- Extend the substitution if the unique has changed
- -- See the notes with substTyVarBndr for the delSubstEnv
- new_env | new_id /= old_id
- = extendVarEnv env old_id (DoneId new_id (idOccInfo old_id))
- | otherwise
- = delVarEnv env old_id
-\end{code}
-
-Now a variant that unconditionally allocates a new unique.
-It also unconditionally zaps the OccInfo.
-
-\begin{code}
-subst_clone_id :: Subst -- Substitution to use (lazily) for the rules and worker
- -> Subst -> (Id, Unique) -- Substitition and Id to transform
- -> (Subst, Id) -- Transformed pair
-
-subst_clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
- = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
- where
- id1 = setVarUnique old_id uniq
- id2 = substIdType subst id1
-
- new_id = maybeModifyIdInfo (substIdInfo False rec_subst) id2
- new_env = extendVarEnv env old_id (DoneId new_id NoOccInfo)
-
-substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
-substAndCloneIds subst us ids
- = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply us)
-
-substAndCloneRecIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
-substAndCloneRecIds subst us ids
- = (subst', ids')
- where
- (subst', ids') = mapAccumL (subst_clone_id subst') subst
- (ids `zip` uniqsFromSupply us)
-
-substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
-substAndCloneId subst us old_id
- = subst_clone_id subst subst (old_id, uniqFromSupply us)
-\end{code}
-
-
-%************************************************************************
-%* *
-\section{IdInfo substitution}
-%* *
-%************************************************************************
-
-\begin{code}
-substIdInfo :: Bool -- True <=> keep even fragile info
- -> Subst
- -> 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.
---
--- Substitute the
--- rules
--- worker info
--- Zap the unfolding
--- If keep_fragile then
--- keep OccInfo
--- keep Arity
--- else
--- 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 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` substRules subst old_rules
- `setWorkerInfo` substWorker subst old_wrkr
- `setUnfoldingInfo` noUnfolding)
- -- setSpecInfo does a seq
- -- setWorkerInfo does a seq
- where
- nothing_to_do = keep_occ && keep_arity &&
- isEmptyCoreRules 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
- old_arity = arityInfo info
- old_occ = occInfo info
- old_rules = specInfo info
- old_wrkr = workerInfo info
-
-------------------
-substIdType :: Subst -> Id -> Id
-substIdType subst@(Subst in_scope id_env tv_env) id
- | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
- | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
- -- The tyVarsOfType is cheaper than it looks
- -- because we cache the free tyvars of the type
- -- in a Note in the id's type itself
- where
- old_ty = idType id
-
-------------------
-substWorker :: Subst -> WorkerInfo -> WorkerInfo
- -- Seq'ing on the returned WorkerInfo is enough to cause all the
- -- substitutions to happen completely
-
-substWorker subst NoWorker
- = NoWorker
-substWorker subst (HasWorker w a)
- = case substId subst w of
- DoneId w1 _ -> HasWorker w1 a
- DoneEx (Var w1) -> HasWorker w1 a
- DoneEx other -> WARN( not (exprIsTrivial other), text "substWorker: DoneEx" <+> ppr w )
- NoWorker -- Worker has got substituted away altogether
- -- This can happen if it's trivial,
- -- via postInlineUnconditionally
- ContEx se1 e -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
- NoWorker -- Ditto
-
-------------------
-substUnfolding subst NoUnfolding = NoUnfolding
-substUnfolding subst (OtherCon cons) = OtherCon cons
-substUnfolding subst (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr subst rhs)
-substUnfolding subst (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr subst rhs) t v w g
-
-------------------
-substRules :: Subst -> CoreRules -> CoreRules
- -- Seq'ing on the returned CoreRules is enough to cause all the
- -- substitutions to happen completely
-
-substRules subst rules
- | isEmptySubst subst = rules
-
-substRules subst (Rules rules rhs_fvs)
- = seqRules new_rules `seq` new_rules
- where
- new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
-
- do_subst rule@(BuiltinRule _ _) = rule
- do_subst (Rule name act tpl_vars lhs_args rhs)
- = Rule name act tpl_vars'
- (map (substExpr subst') lhs_args)
- (substExpr subst' rhs)
- where
- (subst', tpl_vars') = substBndrs subst tpl_vars
-
-------------------
-substVarSet subst fvs
- = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
- where
- subst_fv subst fv
- | isId fv = case substId subst fv of
- DoneId fv' _ -> unitVarSet fv'
- DoneEx expr -> exprFreeVars expr
- ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
- | otherwise = case lookupTvSubst subst fv of
- Nothing -> unitVarSet fv
- Just ty -> substVarSet subst (tyVarsOfType ty)
-\end{code}
import Name ( Name, isExternalName )
import CoreSyn
import PprCore ( pprIdRules, pprCoreExpr )
-import Subst ( SubstResult(..), substExpr, mkSubst, extendIdSubstList )
+import CoreSubst ( substExpr, mkSubst )
import DsMonad
import DsExpr ( dsLExpr )
import DsBinds ( dsHsBinds, AutoScc(..) )
-- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form
let
- subst = extendIdSubstList (mkSubst all_vars) pairs
- pairs = [(id, ContEx subst rhs) | (id,rhs) <- dict_binds']
+ subst = mkSubst all_vars emptyVarEnv (mkVarEnv id_pairs)
+ id_pairs = [(id, substExpr subst rhs) | (id,rhs) <- dict_binds']
-- Note recursion here... substitution won't terminate
-- if there is genuine recursion... which there isn't
+
body'' = substExpr subst body'
in
import CmdLineOpts ( FloatOutSwitches(..) )
import CoreUtils ( exprType, exprIsTrivial, exprIsCheap, mkPiTypes )
import CoreFVs -- all of it
-import Subst ( Subst, SubstResult(..), emptySubst, extendInScope, extendIdSubst,
- substAndCloneId, substAndCloneRecIds )
+import CoreSubst ( Subst, emptySubst, extendInScope, extendIdSubst,
+ cloneIdBndr, cloneRecIdBndrs )
import Id ( Id, idType, mkSysLocalUnencoded,
isOneShotLambda, zapDemandIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo
extendCaseBndrLvlEnv (float_lams, lvl_env, subst, id_env) (Var scrut_var) case_bndr lvl
= (float_lams,
extendVarEnv lvl_env case_bndr lvl,
- extendIdSubst subst case_bndr (DoneEx (Var scrut_var)),
+ extendIdSubst subst case_bndr (Var scrut_var),
extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var))
extendCaseBndrLvlEnv env scrut case_bndr lvl
foldl add_id id_env bndr_pairs)
where
add_lvl env (v,v') = extendVarEnv env v' dest_lvl
- add_subst env (v,v') = extendIdSubst env v (DoneEx (mkVarApps (Var v') abs_vars))
+ add_subst env (v,v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)
add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
extendCloneLvlEnv lvl (float_lams, lvl_env, _, id_env) new_subst bndr_pairs
= ASSERT( isId v )
getUs `thenLvl` \ us ->
let
- (subst', v1) = substAndCloneId subst us v
+ (subst', v1) = cloneIdBndr subst us v
v2 = zap_demand ctxt_lvl dest_lvl v1
env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)]
in
= ASSERT( all isId vs )
getUs `thenLvl` \ us ->
let
- (subst', vs1) = substAndCloneRecIds subst us vs
+ (subst', vs1) = cloneRecIdBndrs subst us vs
vs2 = map (zap_demand ctxt_lvl dest_lvl) vs1
env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2)
in
import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
-import SimplUtils ( simplBinders )
+import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
import SimplMonad
import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
import CoreLint ( endPass )
; us <- mkSplitUniqSupply 's'
- ; let env = emptySimplEnv SimplGently []
- (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
+ ; let (expr', _counts) = initSmpl dflags us $
+ simplExprGently gentleSimplEnv expr
; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
(pprCoreExpr expr')
; return expr'
}
+gentleSimplEnv :: SimplEnv
+gentleSimplEnv = mkSimplEnv SimplGently
+ (panic "simplifyExpr: switches")
+ emptyRuleBase
+
doCorePasses :: HscEnv
-> UniqSupply -- uniques
-> SimplCount -- simplifier stats
; let -- Simplify the local rules; boringly, we need to make an in-scope set
-- from the local binders, to avoid warnings from Simplify.simplVar
local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
- env = setInScopeSet (emptySimplEnv SimplGently []) local_ids
+ env = setInScopeSet gentleSimplEnv local_ids
(better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
(orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
SimplGently -> "gentle"
SimplPhase n -> show n
- simpl_env = emptySimplEnv mode switches
- sw_chkr = getSwitchChecker simpl_env
+ sw_chkr = isAmongSimpl switches
max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
do_iteration us rule_base iteration_no counts guts
-- miss the rules for Ids hidden inside imported inlinings
new_rules <- loadImportedRules hsc_env guts ;
let { rule_base' = extendRuleBaseList rule_base new_rules
- ; in_scope = mkInScopeSet (ruleBaseIds rule_base')
- ; simpl_env' = setInScopeSet simpl_env in_scope } ;
+ ; simpl_env = mkSimplEnv mode sw_chkr rule_base' } ;
-- The new rule base Ids are used to initialise
-- the in-scope set. That way, the simplifier will change any
-- occurrences of the imported id to the one in the imported_rule_ids
-- case t of {(_,counts') -> if counts'=0 then ... }
-- So the conditional didn't force counts', because the
-- selection got duplicated. Sigh!
- case initSmpl dflags us1 (simplTopBinds simpl_env' tagged_binds) of {
+ case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
(binds', counts') -> do {
let { guts' = guts { mg_binds = binds' }
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1993-1998
+%
+\section[SimplMonad]{The simplifier Monad}
+
+\begin{code}
+module SimplEnv (
+ InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
+ OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
+
+ -- The simplifier mode
+ setMode, getMode,
+
+ -- Switch checker
+ SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
+ isAmongSimpl, intSwitchSet, switchIsOn,
+
+ setEnclosingCC, getEnclosingCC,
+
+ -- Environments
+ SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst,
+ zapSubstEnv, setSubstEnv,
+ getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
+ getRules,
+
+ SimplSR(..), mkContEx, substId,
+
+ simplLetBndr, simplLetBndrs, simplLamBndr, simplLamBndrs,
+ simplBinder, simplBinders,
+ simplIdInfo, substExpr, substTy,
+
+ -- Floats
+ FloatsWith, FloatsWithExpr,
+ Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
+ allLifted, wrapFloats, floatBinds,
+ addAuxiliaryBind,
+ ) where
+
+#include "HsVersions.h"
+
+import SimplMonad
+import Rules ( RuleBase, emptyRuleBase )
+import Id ( Id, idType, idOccInfo, idInlinePragma, idUnfolding, setIdUnfolding )
+import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
+ arityInfo, setArityInfo, workerInfo, setWorkerInfo,
+ unfoldingInfo, setUnfoldingInfo,
+ unknownArity, workerExists
+ )
+import CoreSyn
+import CoreUtils ( needsCaseBinding, exprIsTrivial )
+import PprCore () -- Instances
+import CostCentre ( CostCentreStack, subsumedCCS )
+import Var
+import VarEnv
+import VarSet ( isEmptyVarSet )
+import OrdList
+
+import qualified CoreSubst ( Subst, mkSubst, substExpr, substRules, 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 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}
+
+%************************************************************************
+%* *
+\subsection[Simplify-types]{Type declarations}
+%* *
+%************************************************************************
+
+\begin{code}
+type InBinder = CoreBndr
+type InId = Id -- Not yet cloned
+type InType = Type -- Ditto
+type InBind = CoreBind
+type InExpr = CoreExpr
+type InAlt = CoreAlt
+type InArg = CoreArg
+
+type OutBinder = CoreBndr
+type OutId = Id -- Cloned
+type OutTyVar = TyVar -- Cloned
+type OutType = Type -- Cloned
+type OutBind = CoreBind
+type OutExpr = CoreExpr
+type OutAlt = CoreAlt
+type OutArg = CoreArg
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{The @SimplEnv@ type}
+%* *
+%************************************************************************
+
+
+\begin{code}
+data SimplEnv
+ = SimplEnv {
+ seMode :: SimplifierMode,
+ seChkr :: SwitchChecker,
+ seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
+
+ -- Rules from other modules
+ seExtRules :: RuleBase,
+
+ -- The current set of in-scope variables
+ -- They are all OutVars, and all bound in this module
+ seInScope :: InScopeSet, -- OutVars only
+
+ -- The current substitution
+ seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
+ seIdSubst :: SimplIdSubst -- InId |--> OutExpr
+ }
+
+type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
+
+data SimplSR
+ = DoneEx OutExpr -- Completed term
+ | DoneId OutId OccInfo -- Completed term variable, with occurrence info
+ | ContEx TvSubstEnv -- A suspended substitution
+ SimplIdSubst
+ InExpr
+\end{code}
+
+
+seInScope:
+ 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
+
+ The Ids in the InScopeSet are replete with their Rules,
+ and as we gather info about the unfolding of an Id, we replace
+ it in the in-scope set.
+
+ The in-scope set is actually a mapping OutVar -> OutVar, and
+ in case expressions we sometimes bind
+
+seIdSubst:
+ The substitution is *apply-once* only, because InIds and OutIds can overlap.
+ For example, we generally omit mappings
+ a77 -> a77
+ from the substitution, when we decide not to clone a77, but it's quite
+ legitimate to put the mapping in the substitution anyway.
+
+ Indeed, we do so when we want to pass fragile OccInfo to the
+ occurrences of the variable; we add a substitution
+ x77 -> DoneId x77 occ
+ to record x's occurrence information.]
+
+ Furthermore, consider
+ let x = case k of I# x77 -> ... in
+ let y = case k of I# x77 -> ... in ...
+ and suppose the body is strict in both x and y. Then the simplifier
+ will pull the first (case k) to the top; so the second (case k) will
+ cancel out, mapping x77 to, well, x77! But one is an in-Id and the
+ other is an out-Id.
+
+ Of course, the substitution *must* applied! Things in its domain
+ simply aren't necessarily bound in the result.
+
+* substId adds a binding (DoneId new_id occ) to the substitution if
+ EITHER the Id's unique has changed
+ OR the Id has interesting occurrence information
+ So in effect you can only get to interesting occurrence information
+ by looking up the *old* Id; it's not really attached to the new id
+ at all.
+
+ Note, though that the substitution isn't necessarily extended
+ if the type changes. Why not? Because of the next point:
+
+* We *always, always* finish by looking up in the in-scope set
+ any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
+ Reason: so that we never finish up with a "old" Id in the result.
+ An old Id might point to an old unfolding and so on... which gives a space leak.
+
+ [The DoneEx and DoneVar hits map to "new" stuff.]
+
+* It follows that substExpr must not do a no-op if the substitution is empty.
+ substType is free to do so, however.
+
+* When we come to a let-binding (say) we generate new IdInfo, including an
+ unfolding, attach it to the binder, and add this newly adorned binder to
+ the in-scope set. So all subsequent occurrences of the binder will get mapped
+ to the full-adorned binder, which is also the one put in the binding site.
+
+* The in-scope "set" usually maps x->x; we use it simply for its domain.
+ But sometimes we have two in-scope Ids that are synomyms, and should
+ map to the same target: x->x, y->x. Notably:
+ case y of x { ... }
+ That's why the "set" is actually a VarEnv Var
+
+
+Note [GADT type refinement]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we come to a GADT pattern match that refines the in-scope types, we
+ a) Refine the types of the Ids in the in-scope set, seInScope.
+ For exmaple, consider
+ data T a where
+ Foo :: T (Bool -> Bool)
+
+ (\ (x::T a) (y::a) -> case x of { Foo -> y True }
+
+ Technically this is well-typed, but exprType will barf on the
+ (y True) unless we refine the type on y's occurrence.
+
+ b) Refine the range of the type substitution, seTvSubst.
+ Very similar reason to (a).
+
+ NB: we don't refine the range of the SimplIdSubst, because it's always
+ interpreted relative to the seInScope (see substId)
+
+For (b) we need to be a little careful. Specifically, we compose the refinement
+with the type substitution. Suppose
+ The substitution was [a->b, b->a]
+ and the refinement was [b->Int]
+ Then we want [a->Int, b->a]
+
+But also if
+ The substitution was [a->b]
+ and the refinement was [b->Int]
+ Then we want [a->Int, b->Int]
+ becuase b might be both an InTyVar and OutTyVar
+
+
+\begin{code}
+mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
+mkSimplEnv mode switches rules
+ = SimplEnv { seChkr = switches, seCC = subsumedCCS,
+ seMode = mode, seInScope = emptyInScopeSet,
+ seExtRules = rules,
+ seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
+ -- 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}
+
+---------------------
+extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
+extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
+ = env {seIdSubst = extendVarEnv subst var res}
+
+extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
+extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
+ = env {seTvSubst = extendVarEnv subst var res}
+
+---------------------
+getInScope :: SimplEnv -> InScopeSet
+getInScope env = seInScope env
+
+setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
+setInScopeSet env in_scope = env {seInScope = in_scope}
+
+setInScope :: SimplEnv -> SimplEnv -> SimplEnv
+setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
+
+addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
+ -- 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?
+
+modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
+modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
+ = env {seInScope = modifyInScopeSet in_scope v v'}
+
+---------------------
+zapSubstEnv :: SimplEnv -> SimplEnv
+zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
+
+setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
+setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
+
+mkContEx :: SimplEnv -> InExpr -> SimplSR
+mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
+
+isEmptySimplSubst :: SimplEnv -> Bool
+isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
+ = isEmptyVarEnv tvs && isEmptyVarEnv ids
+
+---------------------
+getRules :: SimplEnv -> RuleBase
+getRules = seExtRules
+\end{code}
+
+
+%************************************************************************
+%* *
+ Substitution of Vars
+%* *
+%************************************************************************
+
+
+\begin{code}
+substId :: SimplEnv -> Id -> SimplSR
+substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
+ | not (isLocalId v)
+ = DoneId v NoOccInfo
+ | otherwise -- A local Id
+ = case lookupVarEnv ids v of
+ Just (DoneId v occ) -> DoneId (refine v) occ
+ Just res -> res
+ Nothing -> let v' = refine v
+ in DoneId v' (idOccInfo v')
+ -- We don't put LoopBreakers in the substitution (unless then need
+ -- to be cloned for name-clash rasons), so the idOccInfo is
+ -- very important! If isFragileOcc returned True for
+ -- loop breakers we could avoid this call, but at the expense
+ -- of adding more to the substitution, and building new Ids
+ -- a bit more often than really necessary
+ where
+ -- Get the most up-to-date thing from the in-scope set
+ -- Even though it isn't in the substitution, it may be in
+ -- the in-scope set with a different type (we only use the
+ -- substitution if the unique changes).
+ refine v = case lookupInScope in_scope v of
+ Just v' -> v'
+ Nothing -> WARN( True, ppr v ) v -- This is an error!
+
+\end{code}
+
+
+%************************************************************************
+%* *
+\section{Substituting an Id binder}
+%* *
+%************************************************************************
+
+
+These functions are in the monad only so that they can be made strict via seq.
+
+\begin{code}
+simplBinders, simplLamBndrs, simplLetBndrs
+ :: 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)
+-- Used for lambda and case-bound variables
+-- Clone Id if necessary, substitute type
+-- Return with IdInfo already substituted, but (fragile) occurrence info zapped
+-- The substitution is extended only if the variable is cloned, because
+-- we *don't* need to use it to track occurrence info.
+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
+ ; 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
+-- be reconstructed from context. For example:
+-- f x = case x of (a,b) -> fw a b x
+-- fw a b x{=(a,b)} = ...
+-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
+simplLamBndr env bndr
+ | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr -- Normal case
+ | otherwise = seqId id2 `seq` return (env', id2)
+ where
+ old_unf = idUnfolding bndr
+ (env', id1) = substIdBndr False env 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
+
+-- 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
+-- * 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})
+ old_id
+ = (env { seInScope = in_scope `extendInScopeSet` new_id,
+ seIdSubst = new_subst }, new_id)
+ where
+ -- id1 is cloned if necessary
+ id1 = uniqAway in_scope old_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
+
+ -- Extend the substitution if the unique has changed
+ -- See the notes with substTyVarBndr for the delSubstEnv
+ new_subst | new_id /= old_id
+ = extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id))
+ | otherwise
+ = delVarEnv id_subst old_id
+
+substLetId :: SimplEnv -> Id -> (SimplEnv, Id)
+-- A variant for let-bound Ids
+-- Clone Id if necessary
+-- Substitute its type
+-- Return an Id with completely zapped IdInfo
+-- [A subsequent substIdInfo 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
+ = (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
+
+ -- 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
+ 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
+%* *
+%************************************************************************
+
+\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}
+
+
+%************************************************************************
+%* *
+\section{IdInfo substitution}
+%* *
+%************************************************************************
+
+\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.
+--
+-- Substitute the
+-- rules
+-- worker info
+-- Zap the unfolding
+-- If keep_fragile then
+-- keep OccInfo
+-- keep Arity
+-- else
+-- 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
+ | 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
+ `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 &&
+ not (workerExists old_wrkr) &&
+ not (hasUnfolding (unfoldingInfo info))
+
+ keep_occ = keep_fragile || not (isFragileOcc old_occ)
+ keep_arity = keep_fragile || old_arity == unknownArity
+ old_arity = arityInfo info
+ old_occ = occInfo info
+ old_rules = specInfo info
+ old_wrkr = workerInfo info
+
+------------------
+substIdType :: SimplEnv -> Id -> Id
+substIdType env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
+ | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
+ | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
+ -- The tyVarsOfType is cheaper than it looks
+ -- because we cache the free tyvars of the type
+ -- in a Note in the id's type itself
+ where
+ old_ty = idType id
+
+------------------
+substUnfolding env NoUnfolding = NoUnfolding
+substUnfolding env (OtherCon cons) = OtherCon cons
+substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs)
+substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Floats}
+%* *
+%************************************************************************
+
+\begin{code}
+type FloatsWithExpr = FloatsWith OutExpr
+type FloatsWith a = (Floats, a)
+ -- We return something equivalent to (let b in e), but
+ -- in pieces to avoid the quadratic blowup when floating
+ -- incrementally. Comments just before simplExprB in Simplify.lhs
+
+data Floats = Floats (OrdList OutBind)
+ InScopeSet -- Environment "inside" all the floats
+ Bool -- True <=> All bindings are lifted
+
+allLifted :: Floats -> Bool
+allLifted (Floats _ _ is_lifted) = is_lifted
+
+wrapFloats :: Floats -> OutExpr -> OutExpr
+wrapFloats (Floats bs _ _) body = foldrOL Let body bs
+
+isEmptyFloats :: Floats -> Bool
+isEmptyFloats (Floats bs _ _) = isNilOL bs
+
+floatBinds :: Floats -> [OutBind]
+floatBinds (Floats bs _ _) = fromOL bs
+
+flattenFloats :: Floats -> Floats
+-- Flattens into a single Rec group
+flattenFloats (Floats bs is is_lifted)
+ = ASSERT2( is_lifted, ppr (fromOL bs) )
+ Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
+\end{code}
+
+\begin{code}
+emptyFloats :: SimplEnv -> Floats
+emptyFloats env = Floats nilOL (getInScope env) True
+
+unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
+-- A single non-rec float; extend the in-scope set
+unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
+ (extendInScopeSet (getInScope env) var)
+ (not (isUnLiftedType (idType var)))
+
+addFloats :: SimplEnv -> Floats
+ -> (SimplEnv -> SimplM (FloatsWith a))
+ -> SimplM (FloatsWith a)
+addFloats env (Floats b1 is1 l1) thing_inside
+ | isNilOL b1
+ = thing_inside env
+ | otherwise
+ = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) ->
+ returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
+
+addLetBind :: OutBind -> Floats -> Floats
+addLetBind bind (Floats binds in_scope lifted)
+ = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
+
+is_lifted_bind (Rec _) = True
+is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
+
+-- addAuxiliaryBind * takes already-simplified things (bndr and rhs)
+-- * extends the in-scope env
+-- * assumes it's a let-bindable thing
+addAuxiliaryBind :: SimplEnv -> OutBind
+ -> (SimplEnv -> SimplM (FloatsWith a))
+ -> SimplM (FloatsWith a)
+ -- Extends the in-scope environment as well as wrapping the bindings
+addAuxiliaryBind env bind thing_inside
+ = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
+ thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) ->
+ returnSmpl (addLetBind bind floats, x)
+\end{code}
+
+
\begin{code}
module SimplMonad (
- InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
- OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
- FloatsWith, FloatsWithExpr,
-
-- The monad
SimplM,
initSmpl, returnSmpl, thenSmpl, thenSmpl_,
mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
getDOptsSmpl,
- -- The simplifier mode
- setMode, getMode,
-
-- Unique supply
- getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl,
+ getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, newId,
-- Counting
SimplCount, Tick(..),
plusSimplCount, isZeroSimplCount,
-- Switch checker
- SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
- isAmongSimpl, intSwitchSet, switchIsOn,
-
- -- Cost centres
- getEnclosingCC, setEnclosingCC,
-
- -- Environments
- SimplEnv, emptySimplEnv, getSubst, setSubst, extendIdSubst, extendTvSubst,
- zapSubstEnv, setSubstEnv, getTvSubst, setTvSubstEnv,
- getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
-
- -- Floats
- Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
- allLifted, wrapFloats, floatBinds,
- addAuxiliaryBind,
-
- -- Inlining,
- preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
- inlineMode
+ SwitchChecker, SwitchResult(..), getSimplIntSwitch,
+ isAmongSimpl, intSwitchSet, switchIsOn
) where
#include "HsVersions.h"
-import Id ( Id, idType, idOccInfo, idInlinePragma )
-import CoreSyn
-import CoreUtils ( needsCaseBinding, exprIsTrivial )
-import PprCore () -- Instances
-import CostCentre ( CostCentreStack, subsumedCCS )
-import Var
-import VarEnv
-import OrdList
-import qualified Subst
-import Subst ( Subst, SubstResult, emptySubst, substInScope, isInScope )
-import Type ( Type, TvSubst, TvSubstEnv, isUnLiftedType )
+import Id ( Id, mkSysLocal )
+import Type ( Type )
import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
UniqSupply
)
-import FiniteMap
-import BasicTypes ( TopLevelFlag, isTopLevel, isLoopBreaker,
- Activation, isActive, isAlwaysActive,
- OccInfo(..), isOneOcc
- )
-import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..),
- DynFlags, DynFlag(..), dopt,
- opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining, opt_RulesOff
+import CmdLineOpts ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt,
+ opt_PprStyle_Debug, opt_HistorySize,
)
+import OccName ( EncodedFS )
import Unique ( Unique )
+import Maybes ( expectJust )
+import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList )
+import FastString ( FastString )
import Outputable
import FastTypes
-import FastString
-import Maybes ( expectJust )
import GLAEXTS ( indexArray# )
%************************************************************************
%* *
-\subsection[Simplify-types]{Type declarations}
-%* *
-%************************************************************************
-
-\begin{code}
-type InBinder = CoreBndr
-type InId = Id -- Not yet cloned
-type InType = Type -- Ditto
-type InBind = CoreBind
-type InExpr = CoreExpr
-type InAlt = CoreAlt
-type InArg = CoreArg
-
-type OutBinder = CoreBndr
-type OutId = Id -- Cloned
-type OutTyVar = TyVar -- Cloned
-type OutType = Type -- Cloned
-type OutBind = CoreBind
-type OutExpr = CoreExpr
-type OutAlt = CoreAlt
-type OutArg = CoreArg
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Floats}
-%* *
-%************************************************************************
-
-\begin{code}
-type FloatsWithExpr = FloatsWith OutExpr
-type FloatsWith a = (Floats, a)
- -- We return something equivalent to (let b in e), but
- -- in pieces to avoid the quadratic blowup when floating
- -- incrementally. Comments just before simplExprB in Simplify.lhs
-
-data Floats = Floats (OrdList OutBind)
- InScopeSet -- Environment "inside" all the floats
- Bool -- True <=> All bindings are lifted
-
-allLifted :: Floats -> Bool
-allLifted (Floats _ _ is_lifted) = is_lifted
-
-wrapFloats :: Floats -> OutExpr -> OutExpr
-wrapFloats (Floats bs _ _) body = foldrOL Let body bs
-
-isEmptyFloats :: Floats -> Bool
-isEmptyFloats (Floats bs _ _) = isNilOL bs
-
-floatBinds :: Floats -> [OutBind]
-floatBinds (Floats bs _ _) = fromOL bs
-
-flattenFloats :: Floats -> Floats
--- Flattens into a single Rec group
-flattenFloats (Floats bs is is_lifted)
- = ASSERT2( is_lifted, ppr (fromOL bs) )
- Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
-\end{code}
-
-\begin{code}
-emptyFloats :: SimplEnv -> Floats
-emptyFloats env = Floats nilOL (getInScope env) True
-
-unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
--- A single non-rec float; extend the in-scope set
-unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
- (extendInScopeSet (getInScope env) var)
- (not (isUnLiftedType (idType var)))
-
-addFloats :: SimplEnv -> Floats
- -> (SimplEnv -> SimplM (FloatsWith a))
- -> SimplM (FloatsWith a)
-addFloats env (Floats b1 is1 l1) thing_inside
- | isNilOL b1
- = thing_inside env
- | otherwise
- = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) ->
- returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
-
-addLetBind :: OutBind -> Floats -> Floats
-addLetBind bind (Floats binds in_scope lifted)
- = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
-
-is_lifted_bind (Rec _) = True
-is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
-
--- addAuxiliaryBind * takes already-simplified things (bndr and rhs)
--- * extends the in-scope env
--- * assumes it's a let-bindable thing
-addAuxiliaryBind :: SimplEnv -> OutBind
- -> (SimplEnv -> SimplM (FloatsWith a))
- -> SimplM (FloatsWith a)
- -- Extends the in-scope environment as well as wrapping the bindings
-addAuxiliaryBind env bind thing_inside
- = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
- thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) ->
- returnSmpl (addLetBind bind floats, x)
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Monad plumbing}
%* *
%************************************************************************
(Command-line switches move around through the explicitly-passed SimplEnv.)
\begin{code}
-type SimplM result
- = DynFlags -- We thread the unique supply because
- -> UniqSupply -- constantly splitting it is rather expensive
- -> SimplCount
- -> (result, UniqSupply, SimplCount)
+newtype SimplM result
+ = SM { unSM :: DynFlags -- We thread the unique supply because
+ -> UniqSupply -- constantly splitting it is rather expensive
+ -> SimplCount
+ -> (result, UniqSupply, SimplCount)}
\end{code}
\begin{code}
-> (a, SimplCount)
initSmpl dflags us m
- = case m dflags us (zeroSimplCount dflags) of
+ = case unSM m dflags us (zeroSimplCount dflags) of
(result, _, count) -> (result, count)
{-# INLINE thenSmpl_ #-}
{-# INLINE returnSmpl #-}
+instance Monad SimplM where
+ (>>) = thenSmpl_
+ (>>=) = thenSmpl
+ return = returnSmpl
+
returnSmpl :: a -> SimplM a
-returnSmpl e dflags us sc = (e, us, sc)
+returnSmpl e = SM (\ dflags us sc -> (e, us, sc))
thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
-thenSmpl m k dflags us0 sc0
- = case (m dflags us0 sc0) of
- (m_result, us1, sc1) -> k m_result dflags us1 sc1
+thenSmpl m k
+ = SM (\ dflags us0 sc0 ->
+ case (unSM m dflags us0 sc0) of
+ (m_result, us1, sc1) -> unSM (k m_result) dflags us1 sc1 )
-thenSmpl_ m k dflags us0 sc0
- = case (m dflags us0 sc0) of
- (_, us1, sc1) -> k dflags us1 sc1
+thenSmpl_ m k
+ = SM (\dflags us0 sc0 ->
+ case (unSM m dflags us0 sc0) of
+ (_, us1, sc1) -> unSM k dflags us1 sc1)
\end{code}
mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
returnSmpl (r1:rs1, r2:rs2)
+mapAccumLSmpl :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c])
mapAccumLSmpl f acc [] = returnSmpl (acc, [])
mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
\begin{code}
getUniqSupplySmpl :: SimplM UniqSupply
-getUniqSupplySmpl dflags us sc
- = case splitUniqSupply us of
- (us1, us2) -> (us1, us2, sc)
+getUniqSupplySmpl
+ = SM (\dflags us sc -> case splitUniqSupply us of
+ (us1, us2) -> (us1, us2, sc))
getUniqueSmpl :: SimplM Unique
-getUniqueSmpl dflags us sc
- = case splitUniqSupply us of
- (us1, us2) -> (uniqFromSupply us1, us2, sc)
+getUniqueSmpl
+ = SM (\dflags us sc -> case splitUniqSupply us of
+ (us1, us2) -> (uniqFromSupply us1, us2, sc))
getUniquesSmpl :: SimplM [Unique]
-getUniquesSmpl dflags us sc
- = case splitUniqSupply us of
- (us1, us2) -> (uniqsFromSupply us1, us2, sc)
+getUniquesSmpl
+ = SM (\dflags us sc -> case splitUniqSupply us of
+ (us1, us2) -> (uniqsFromSupply us1, us2, sc))
getDOptsSmpl :: SimplM DynFlags
-getDOptsSmpl dflags us sc
- = (dflags, us, sc)
+getDOptsSmpl
+ = SM (\dflags us sc -> (dflags, us, sc))
+
+newId :: EncodedFS -> Type -> SimplM Id
+newId fs ty = getUniqueSmpl `thenSmpl` \ uniq ->
+ returnSmpl (mkSysLocal fs uniq ty)
\end{code}
\begin{code}
getSimplCount :: SimplM SimplCount
-getSimplCount dflags us sc = (sc, us, sc)
+getSimplCount = SM (\dflags us sc -> (sc, us, sc))
tick :: Tick -> SimplM ()
-tick t dflags us sc
- = sc' `seq` ((), us, sc')
- where
- sc' = doTick t sc
+tick t
+ = SM (\dflags us sc -> let sc' = doTick t sc
+ in sc' `seq` ((), us, sc'))
freeTick :: Tick -> SimplM ()
-- Record a tick, but don't add to the total tick count, which is
-- used to decide when nothing further has happened
-freeTick t dflags us sc
- = sc' `seq` ((), us, sc')
- where
- sc' = doFreeTick t sc
+freeTick t
+ = SM (\dflags us sc -> let sc' = doFreeTick t sc
+ in sc' `seq` ((), us, sc'))
\end{code}
\begin{code}
\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
- where
- phase = getMode env
- active = case phase of
- SimplGently -> isAlwaysActive prag
- SimplPhase n -> isActive n prag
- prag = idInlinePragma bndr
-\end{code}
-
-postInlineUnconditionally
-~~~~~~~~~~~~~~~~~~~~~~~~~
-@postInlineUnconditionally@ decides whether to unconditionally inline
-a thing based on the form of its RHS; in particular if it has a
-trivial RHS. If so, we can inline and discard the binding altogether.
-
-NB: a loop breaker has must_keep_binding = True and non-loop-breakers
-only have *forward* references Hence, it's safe to discard the binding
-
-NOTE: This isn't our last opportunity to inline. We're at the binding
-site right now, and we'll get another opportunity when we get to the
-ocurrence(s)
-
-Note that we do this unconditional inlining only for trival RHSs.
-Don't inline even WHNFs inside lambdas; doing so may simply increase
-allocation when the function is called. This isn't the last chance; see
-NOTE above.
-
-NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
-Because we don't even want to inline them into the RHS of constructor
-arguments. See NOTE above
-
-NB: At one time even NOINLINE was ignored here: if the rhs is trivial
-it's best to inline it anyway. We often get a=E; b=a from desugaring,
-with both a and b marked NOINLINE. But that seems incompatible with
-our new view that inlining is like a RULE, so I'm sticking to the 'active'
-story for now.
-
-\begin{code}
-postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
-postInlineUnconditionally env bndr occ_info rhs
- = exprIsTrivial rhs
- && active
- && 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
-
-activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
-activeInline env id occ
- = case getMode env of
- SimplGently -> isOneOcc occ && isAlwaysActive prag
- -- No inlining at all when doing gentle stuff,
- -- 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.
- -- Example in spectral/mandel/Mandel.hs, where the mandelset
- -- function gets a useful let-float if you inline windowToViewport
-
- -- NB: we used to have a second exception, for data con wrappers.
- -- On the grounds that we use gentle mode for rule LHSs, and
- -- they match better when data con wrappers are inlined.
- -- But that only really applies to the trivial wrappers (like (:)),
- -- and they are now constructed as Compulsory unfoldings (in MkId)
- -- so they'll happen anyway.
-
- SimplPhase n -> isActive n prag
- where
- prag = idInlinePragma id
-
-activeRule :: SimplEnv -> Maybe (Activation -> Bool)
--- Nothing => No rules at all
-activeRule env
- | opt_RulesOff = Nothing
- | otherwise
- = case getMode env of
- 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}
-
-
%************************************************************************
%* *
\subsubsection{Command-line switches}
%************************************************************************
\begin{code}
-getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
-getSimplIntSwitch chkr switch
- = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
-
-switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
-
-switchIsOn lookup_fn switch
- = case (lookup_fn switch) of
- SwBool False -> False
- _ -> True
-
-intSwitchSet :: (switch -> SwitchResult)
- -> (Int -> switch)
- -> Maybe Int
-
-intSwitchSet lookup_fn switch
- = case (lookup_fn (switch (panic "intSwitchSet"))) of
- SwInt int -> Just int
- _ -> Nothing
-\end{code}
-
-
-\begin{code}
type SwitchChecker = SimplifierSwitch -> SwitchResult
data SwitchResult
|| sw `is_elem` ss
\end{code}
+\begin{code}
+getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
+getSimplIntSwitch chkr switch
+ = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
+
+switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
+
+switchIsOn lookup_fn switch
+ = case (lookup_fn switch) of
+ SwBool False -> False
+ _ -> True
+
+intSwitchSet :: (switch -> SwitchResult)
+ -> (Int -> switch)
+ -> Maybe Int
+
+intSwitchSet lookup_fn switch
+ = case (lookup_fn (switch (panic "intSwitchSet"))) of
+ SwInt int -> Just int
+ _ -> Nothing
+\end{code}
+
+
These things behave just like enumeration types.
\begin{code}
\begin{code}
module SimplUtils (
- simplBinder, simplBinders, simplRecBndrs,
- simplLetBndr, simplLamBndrs,
- newId, mkLam, prepareAlts, mkCase,
+ mkLam, prepareAlts, mkCase,
+
+ -- Inlining,
+ preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
+ inlineMode,
-- The continuation type
SimplCont(..), DupFlag(..), LetRhsFlag(..),
#include "HsVersions.h"
-import CmdLineOpts ( SimplifierSwitch(..), opt_UF_UpdateInPlace,
+import SimplEnv
+import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..), opt_UF_UpdateInPlace,
+ opt_SimplNoPreInlining, opt_RulesOff,
DynFlag(..), dopt )
import CoreSyn
import CoreFVs ( exprFreeVars )
findDefault, exprOkForSpeculation, exprIsValue
)
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id ( Id, idType, idInfo, isDataConWorkId,
- mkSysLocal, isDeadBinder, idNewDemandInfo,
- idUnfolding, idNewStrictness
+import Id ( Id, idType, idInfo, isDataConWorkId, idOccInfo,
+ mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
+ idUnfolding, idNewStrictness, idInlinePragma,
)
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
import DataCon ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon )
import Var ( tyVarKind, mkTyVar )
import VarSet
+import BasicTypes ( TopLevelFlag(..), isTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
+ Activation, isAlwaysActive, isActive )
import Util ( lengthExceeds, mapAccumL )
import Outputable
\end{code}
%************************************************************************
%* *
-\section{Dealing with a single binder}
+\subsection{Decisions about inlining}
%* *
%************************************************************************
-These functions are in the monad only so that they can be made strict via seq.
+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}
-simplBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplBinders env bndrs
- = let
- (subst', bndrs') = Subst.simplBndrs (getSubst env) bndrs
- in
- seqBndrs bndrs' `seq`
- returnSmpl (setSubst env subst', bndrs')
+inlineMode :: SimplifierMode
+inlineMode = SimplGently
+\end{code}
-simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
-simplBinder env bndr
- = let
- (subst', bndr') = Subst.simplBndr (getSubst env) bndr
- in
- seqBndr bndr' `seq`
- returnSmpl (setSubst env subst', bndr')
+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.
-simplLetBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
-simplLetBndr env id
- = let
- (subst', id') = Subst.simplLetId (getSubst env) id
- in
- seqBndr id' `seq`
- returnSmpl (setSubst env subst', id')
+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.
-simplLamBndrs, simplRecBndrs
- :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplRecBndrs = simplBndrs Subst.simplLetId
-simplLamBndrs = simplBndrs Subst.simplLamBndr
+Evne RHSs labelled InlineMe aren't caught here, because there might be
+no benefit from inlining at the call site.
-simplBndrs simpl_bndr env bndrs
- = let
- (subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs
- in
- seqBndrs bndrs' `seq`
- returnSmpl (setSubst env subst', bndrs')
+[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
-seqBndrs [] = ()
-seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
+[Remember that we treat \s as a one-shot lambda.] No point in
+inlining x unless there is something interesting about the call site.
-seqBndr b | isTyVar b = b `seq` ()
- | otherwise = seqType (idType b) `seq`
- idInfo b `seq`
- ()
-\end{code}
+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}
-newId :: EncodedFS -> Type -> SimplM Id
-newId fs ty = getUniqueSmpl `thenSmpl` \ uniq ->
- returnSmpl (mkSysLocal fs uniq ty)
+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
+ where
+ phase = getMode env
+ active = case phase of
+ SimplGently -> isAlwaysActive prag
+ SimplPhase n -> isActive n prag
+ prag = idInlinePragma bndr
\end{code}
+postInlineUnconditionally
+~~~~~~~~~~~~~~~~~~~~~~~~~
+@postInlineUnconditionally@ decides whether to unconditionally inline
+a thing based on the form of its RHS; in particular if it has a
+trivial RHS. If so, we can inline and discard the binding altogether.
+
+NB: a loop breaker has must_keep_binding = True and non-loop-breakers
+only have *forward* references Hence, it's safe to discard the binding
+
+NOTE: This isn't our last opportunity to inline. We're at the binding
+site right now, and we'll get another opportunity when we get to the
+ocurrence(s)
+
+Note that we do this unconditional inlining only for trival RHSs.
+Don't inline even WHNFs inside lambdas; doing so may simply increase
+allocation when the function is called. This isn't the last chance; see
+NOTE above.
+
+NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
+Because we don't even want to inline them into the RHS of constructor
+arguments. See NOTE above
+
+NB: At one time even NOINLINE was ignored here: if the rhs is trivial
+it's best to inline it anyway. We often get a=E; b=a from desugaring,
+with both a and b marked NOINLINE. But that seems incompatible with
+our new view that inlining is like a RULE, so I'm sticking to the 'active'
+story for now.
+
+\begin{code}
+postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
+postInlineUnconditionally env bndr occ_info rhs
+ = exprIsTrivial rhs
+ && active
+ && 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
+
+activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
+activeInline env id occ
+ = case getMode env of
+ SimplGently -> isOneOcc occ && isAlwaysActive prag
+ -- No inlining at all when doing gentle stuff,
+ -- 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.
+ -- Example in spectral/mandel/Mandel.hs, where the mandelset
+ -- function gets a useful let-float if you inline windowToViewport
+
+ -- NB: we used to have a second exception, for data con wrappers.
+ -- On the grounds that we use gentle mode for rule LHSs, and
+ -- they match better when data con wrappers are inlined.
+ -- But that only really applies to the trivial wrappers (like (:)),
+ -- and they are now constructed as Compulsory unfoldings (in MkId)
+ -- so they'll happen anyway.
+
+ SimplPhase n -> isActive n prag
+ where
+ prag = idInlinePragma id
+
+activeRule :: SimplEnv -> Maybe (Activation -> Bool)
+-- Nothing => No rules at all
+activeRule env
+ | opt_RulesOff = Nothing
+ | otherwise
+ = case getMode env of
+ 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}
+
%************************************************************************
%* *
SimplifierSwitch(..)
)
import SimplMonad
-import SimplUtils ( mkCase, mkLam, newId, prepareAlts,
- simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
+import SimplEnv
+import SimplUtils ( mkCase, mkLam, prepareAlts,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
mkRhsStop, mkBoringStop, pushContArgs,
contResultType, countArgs, contIsDupable, contIsRhsOrArg,
- getContArgs, interestingCallContext, interestingArg, isStrictType
+ getContArgs, interestingCallContext, interestingArg, isStrictType,
+ preInlineUnconditionally, postInlineUnconditionally,
+ inlineMode, activeInline, activeRule
)
import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
setIdUnfolding, isDeadBinder,
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
- splitFunTy_maybe, splitFunTy, coreEqType, substTy, mkTyVarTys
+ splitFunTy_maybe, splitFunTy, coreEqType, mkTyVarTys
)
import VarEnv ( elemVarEnv )
-import Subst ( SubstResult(..), emptySubst, substExpr,
- substId, simplIdInfo )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
-- so that if a transformation 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.
- simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
+ simplLetBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (floatBinds floats)
simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
| preInlineUnconditionally env NotTopLevel bndr
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
- thing_inside (extendIdSubst env bndr (ContEx (getSubst rhs_se) rhs))
+ thing_inside (extendIdSubst env bndr (mkContEx rhs_se rhs))
| isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
let
-- simplLetBndr doesn't deal with the IdInfo, so we must
-- do so here (c.f. simplLazyBind)
- bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
+ bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr)
env2 = modifyInScope env1 bndr2 bndr2
in
completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside
-- Similarly, single occurrences can be inlined vigourously
-- e.g. case (f x, g y) of (a,b) -> ....
-- If a,b occur once we can avoid constructing the let binding for them.
- = thing_inside (extendIdSubst env bndr (ContEx emptySubst new_rhs))
+ = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
| otherwise
= simplBinder env bndr `thenSmpl` \ (env, bndr') ->
simplRecOrTopPair env top_lvl bndr bndr' rhs
| preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
- returnSmpl (emptyFloats env, extendIdSubst env bndr (ContEx (getSubst env) rhs))
+ returnSmpl (emptyFloats env, extendIdSubst env bndr (mkContEx env rhs))
| otherwise
= simplLazyBind env top_lvl Recursive bndr bndr' rhs env
-- NB 4: does no harm for non-recursive bindings
- bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
+ bndr2 = bndr1 `setIdInfo` simplIdInfo env (idInfo bndr)
env1 = modifyInScope env bndr2 bndr2
rhs_env = setInScope rhs_se env1
is_top_level = isTopLevel top_lvl
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
where
- expr_ty' = substTy (getTvSubst env) (exprType expr)
+ expr_ty' = substTy env (exprType expr)
-- The type in the Stop continuation, expr_ty', is usually not used
-- It's only needed when discarding continuations after finding
-- a function that returns bottom.
rebuild env case_expr' cont
where
case_cont = Select NoDup bndr alts env (mkBoringStop case_ty')
- case_ty' = substTy (getTvSubst env) case_ty -- c.f. defn of simplExpr
+ case_ty' = substTy env case_ty -- c.f. defn of simplExpr
simplExprF env (Let (Rec pairs) body) cont
- = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
+ = simplLetBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
simplType env ty
= seqType new_ty `seq` returnSmpl new_ty
where
- new_ty = substTy (getTvSubst env) ty
+ new_ty = substTy env ty
\end{code}
-- But it isn't a common case.
= let
(t1,t2) = splitFunTy t1t2
- new_arg = mkCoerce2 s1 t1 (substExpr subst arg)
- subst = getSubst (setInScope arg_se env)
+ new_arg = mkCoerce2 s1 t1 (substExpr arg_env arg)
+ arg_env = setInScope arg_se env
in
ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
\begin{code}
simplVar env var cont
- = case substId (getSubst env) var of
- DoneEx e -> simplExprF (zapSubstEnv env) e cont
- ContEx se e -> simplExprF (setSubstEnv env se) e cont
- DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont
+ = case substId env var of
+ DoneEx e -> simplExprF (zapSubstEnv env) e cont
+ ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
+ DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont
-- Note [zapSubstEnv]
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
let
in_scope = getInScope env
+ rules = getRules env
maybe_rule = case activeRule env of
Nothing -> Nothing -- No rules apply
- Just act_fn -> lookupRule act_fn in_scope var args
+ Just act_fn -> lookupRule act_fn in_scope rules var args
in
case maybe_rule of {
Just (rule_name, rule_rhs) ->
simplBinders env tvs `thenSmpl` \ (env1, tvs') ->
let
pat_res_ty = dataConResTy con (mkTyVarTys tvs')
- tv_subst = getTvSubst env1
in
- case coreRefineTys tvs' tv_subst pat_res_ty (idType case_bndr') of {
+ case coreRefineTys tvs' (error "urk") pat_res_ty (idType case_bndr') of {
Nothing -- Dead code; for now, I'm just going to put in an
-- error case so I can see them
-> let rhs' = mkApps (Var eRROR_ID)
- [Type (substTy tv_subst (exprType rhs)),
+ [Type (substTy env (exprType rhs)),
Lit (mkStringLit "Impossible alternative (GADT)")]
in
simplBinders env1 ids `thenSmpl` \ (env2, ids') ->
Just tv_subst_env -> -- The normal case
let
- env2 = setTvSubstEnv env1 tv_subst_env
+ env2 = error "setTvSubstEnv" env1 tv_subst_env
-- Simplify the Ids in the refined environment, so their types
-- reflect the refinement. Usually this doesn't matter, but it helps
-- in mkDupableAlt, when we want to float a lambda that uses these binders
bind_args env bs (drop n_drop_tys args) $ \ env ->
let
con_app = mkConApp dc (take n_drop_tys args ++ con_args)
- con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs]
+ con_args = [substExpr env (varToCoreExpr b) | b <- bs]
-- args are aready OutExprs, but bs are InIds
in
simplNonRecX env bndr con_app $ \ env ->
import CoreUtils ( tcEqExprX )
import Type ( Type )
import CoreTidy ( pprTidyIdRules )
-import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
+import Id ( Id, idUnfolding, isLocalId, idSpecialisation, setIdSpecialisation )
import Var ( Var )
import VarSet
import VarEnv
%************************************************************************
\begin{code}
-lookupRule :: (Activation -> Bool) -> InScopeSet
+lookupRule :: (Activation -> Bool)
+ -> InScopeSet
+ -> RuleBase -- Ids from other modules
-> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
-lookupRule is_active in_scope fn args
- = case idSpecialisation fn of
+lookupRule is_active in_scope rules fn args
+ = case idSpecialisation fn' of
Rules rules _ -> matchRules is_active in_scope rules args
+ where
+ fn' | isLocalId fn = fn
+ | Just ext_fn <- lookupVarSet (ruleBaseIds rules) fn = ext_fn
+ | otherwise = fn
\end{code}
tyVarsOfTypes, tyVarsOfTheta, isClassPred,
tcCmpType, isUnLiftedType
)
-import Subst ( Subst, SubstResult(..), mkSubst, mkSubst, extendTvSubstList,
- simplBndr, simplBndrs, substTy,
- substAndCloneId, substAndCloneIds, substAndCloneRecIds,
- substId, substInScope
+import CoreSubst ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst,
+ substBndr, substBndrs, substTy, substInScope,
+ cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs
)
import Var ( zapSpecPragmaId )
import VarSet
import CoreFVs ( exprFreeVars, exprsFreeVars )
import CoreTidy ( pprTidyIdRules )
import CoreLint ( showPass, endPass )
-import Rules ( addIdSpecialisations, lookupRule )
+import Rules ( addIdSpecialisations, lookupRule, emptyRuleBase )
import UniqSupply ( UniqSupply,
UniqSM, initUs_, thenUs, returnUs, getUniqueUs,
-- accidentally re-use a unique that's already in use
-- Easiest thing is to do it all at once, as if all the top-level
-- decls were mutually recursive
- top_subst = mkSubst (mkInScopeSet (mkVarSet (bindersOfBinds binds)))
+ top_subst = mkEmptySubst (mkInScopeSet (mkVarSet (bindersOfBinds binds)))
go [] = returnSM ([], emptyUDs)
go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
\begin{code}
specVar :: Subst -> Id -> CoreExpr
-specVar subst v = case substId subst v of
- DoneEx e -> e
- DoneId v _ -> Var v
+specVar subst v = lookupIdSubst subst v
specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
-- We carry a substitution down:
returnSM (mkLams bndrs' body'', filtered_uds)
where
(bndrs, body) = collectBinders e
- (subst', bndrs') = simplBndrs subst bndrs
+ (subst', bndrs') = substBndrs subst bndrs
-- More efficient to collect a group of binders together all at once
-- and we don't want to split a lambda group with dumped bindings
mapAndCombineSM spec_alt alts `thenSM` \ (alts', uds_alts) ->
returnSM (Case scrut' case_bndr' (substTy subst ty) alts', uds_scrut `plusUDs` uds_alts)
where
- (subst_alt, case_bndr') = simplBndr subst case_bndr
+ (subst_alt, case_bndr') = substBndr subst case_bndr
-- No need to clone case binder; it can't float like a let(rec)
spec_alt (con, args, rhs)
in
returnSM ((con, args', rhs''), uds')
where
- (subst_rhs, args') = simplBndrs subst_alt args
+ (subst_rhs, args') = substBndrs subst_alt args
---------------- Finally, let is the interesting case --------------------
specExpr subst (Let bind body)
-- *don't* say what the value of the implicit param is!
|| not (spec_tys `lengthIs` n_tyvars)
|| not ( dicts `lengthIs` n_dicts)
- || maybeToBool (lookupRule (\act -> True) (substInScope subst) f args)
+ || maybeToBool (lookupRule (\act -> True) (substInScope subst) emptyRuleBase f args)
-- There's already a rule covering this call. A typical case
-- is where there's an explicit user-provided rule. Then
-- we don't want to create a specialised version
cloneBindSM subst (NonRec bndr rhs)
= getUs `thenUs` \ us ->
let
- (subst', bndr') = substAndCloneId subst us bndr
+ (subst', bndr') = cloneIdBndr subst us bndr
in
returnUs (subst, subst', NonRec bndr' rhs)
cloneBindSM subst (Rec pairs)
= getUs `thenUs` \ us ->
let
- (subst', bndrs') = substAndCloneRecIds subst us (map fst pairs)
+ (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
in
returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
cloneBinders subst bndrs
= getUs `thenUs` \ us ->
- returnUs (substAndCloneIds subst us bndrs)
+ returnUs (cloneIdBndrs subst us bndrs)
newIdSM old_id new_ty
= getUniqSM `thenSM` \ uniq ->
--
-- The new_id isn't cloned, but it may have a different type
-- etc, so we must return it, not the old id
- = (TvSubst (in_scope `extendInScopeSet` new_var) (delVarEnv env old_var),
+ = (TvSubst (in_scope `extendInScopeSet` new_var)
+ (delVarEnv env old_var),
new_var)
| otherwise -- The new binder is in scope so
-- Extending the substitution to do this renaming also
-- has the (correct) effect of discarding any existing
-- substitution for that variable
- = (TvSubst (in_scope `extendInScopeSet` new_var) (extendVarEnv env old_var (TyVarTy new_var)),
+ = (TvSubst (in_scope `extendInScopeSet` new_var)
+ (extendVarEnv env old_var (TyVarTy new_var)),
new_var)
where
new_var = uniqAway in_scope old_var
projects / ghc-hetmet.git / commitdiff