From 339d5220bcb7e8ca344ca5ec6e862d2373267be8 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 24 Dec 2004 16:15:15 +0000 Subject: [PATCH] [project @ 2004-12-24 16:14:36 by simonpj] --------------------------- Refactor the simplifier --------------------------- Driven by a GADT bug, I have refactored the simpifier, and the way GHC treats substitutions. I hope I have gotten it right. Be cautious about updating. * coreSyn/Subst.lhs has gone * coreSyn/CoreSubst replaces it, except that it's quite a bit simpler * simplCore/SimplEnv is added, and contains the simplifier-specific substitution stuff Previously Subst was trying to be all things to all men, and that was making it Too Complicated. There may be a little more code now, but it's much easier to understand. --- ghc/compiler/coreSyn/CoreSubst.lhs | 393 +++++++++++++++++ ghc/compiler/coreSyn/Subst.lhs | 638 ---------------------------- ghc/compiler/deSugar/Desugar.lhs | 7 +- ghc/compiler/simplCore/SetLevels.lhs | 12 +- ghc/compiler/simplCore/SimplCore.lhs | 21 +- ghc/compiler/simplCore/SimplEnv.lhs | 717 ++++++++++++++++++++++++++++++++ ghc/compiler/simplCore/SimplMonad.lhs | 662 ++++------------------------- ghc/compiler/simplCore/SimplUtils.lhs | 312 +++++++++++--- ghc/compiler/simplCore/Simplify.lhs | 56 +-- ghc/compiler/specialise/Rules.lhs | 14 +- ghc/compiler/specialise/Specialise.lhs | 29 +- ghc/compiler/types/Type.lhs | 6 +- 12 files changed, 1526 insertions(+), 1341 deletions(-) create mode 100644 ghc/compiler/coreSyn/CoreSubst.lhs delete mode 100644 ghc/compiler/coreSyn/Subst.lhs create mode 100644 ghc/compiler/simplCore/SimplEnv.lhs diff --git a/ghc/compiler/coreSyn/CoreSubst.lhs b/ghc/compiler/coreSyn/CoreSubst.lhs new file mode 100644 index 0000000..2de0390 --- /dev/null +++ b/ghc/compiler/coreSyn/CoreSubst.lhs @@ -0,0 +1,393 @@ +% +% (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(" 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} diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs deleted file mode 100644 index 86508c2..0000000 --- a/ghc/compiler/coreSyn/Subst.lhs +++ /dev/null @@ -1,638 +0,0 @@ -% -% (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(" 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} diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 36fd15c..06000d7 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -19,7 +19,7 @@ import Id ( Id, setIdExported, idName, idIsFrom, isLocalId ) 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(..) ) @@ -282,10 +282,11 @@ ds_lhs all_vars lhs -- 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 diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index e677488..d8d4ff0 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -58,8 +58,8 @@ import CoreSyn 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 @@ -682,7 +682,7 @@ extendLvlEnv (float_lams, lvl_env, subst, id_env) prs 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 @@ -695,7 +695,7 @@ extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pai 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 @@ -819,7 +819,7 @@ cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl = 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 @@ -832,7 +832,7 @@ cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl = 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 diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 4e77ca9..e567e78 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -24,7 +24,7 @@ import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules ) 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 ) @@ -98,8 +98,8 @@ simplifyExpr dflags expr ; 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') @@ -107,6 +107,11 @@ simplifyExpr dflags expr ; return expr' } +gentleSimplEnv :: SimplEnv +gentleSimplEnv = mkSimplEnv SimplGently + (panic "simplifyExpr: switches") + emptyRuleBase + doCorePasses :: HscEnv -> UniqSupply -- uniques -> SimplCount -- simplifier stats @@ -216,7 +221,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) ; 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 @@ -413,8 +418,7 @@ simplifyPgm mode switches hsc_env us rule_base guts 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 @@ -455,8 +459,7 @@ simplifyPgm mode switches hsc_env us rule_base 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 @@ -473,7 +476,7 @@ simplifyPgm mode switches hsc_env us rule_base guts -- 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' } diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs new file mode 100644 index 0000000..e7792e8 --- /dev/null +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -0,0 +1,717 @@ +% +% (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} + + diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 206e8d0..7d02906 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -5,21 +5,14 @@ \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(..), @@ -28,57 +21,27 @@ module SimplMonad ( 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# ) @@ -95,108 +58,6 @@ infixr 0 `thenSmpl`, `thenSmpl_` %************************************************************************ %* * -\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} %* * %************************************************************************ @@ -205,11 +66,11 @@ For the simplifier monad, we want to {\em thread} a unique supply and a counter. (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} @@ -219,7 +80,7 @@ initSmpl :: DynFlags -> (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) @@ -227,19 +88,26 @@ initSmpl dflags us m {-# 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} @@ -259,6 +127,7 @@ mapAndUnzipSmpl f (x:xs) 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') -> @@ -274,23 +143,27 @@ mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> \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} @@ -302,21 +175,19 @@ getDOptsSmpl dflags us sc \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} @@ -559,385 +430,6 @@ cmpEqTick other1 other2 = EQ \end{code} - -%************************************************************************ -%* * -\subsubsection{The @SimplEnv@ type} -%* * -%************************************************************************ - - -\begin{code} -data SimplEnv - = SimplEnv { - seMode :: SimplifierMode, - seChkr :: SwitchChecker, - seCC :: CostCentreStack, -- The enclosing CCS (when profiling) - seSubst :: Subst -- The current substitution - } - -- The range of the substitution is OutType and OutExpr resp - -- - -- The substitution is idempotent - -- It *must* be applied; things in its domain simply aren't - -- bound in the result. - -- - -- The substitution usually maps an Id to its clone, - -- but if the orig defn is a let-binding, and - -- the RHS of the let simplifies to an atom, - -- we just add the binding to the substitution and elide the let. - - -- The in-scope part of Subst includes *all* in-scope TyVars and Ids - -- The elements of the set may have better IdInfo than the - -- occurrences of in-scope Ids, and (more important) they will - -- have a correctly-substituted type. So we use a lookup in this - -- set to replace occurrences - -emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> SimplEnv -emptySimplEnv mode switches - = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS, - seMode = mode, seSubst = emptySubst } - -- The top level "enclosing CC" is "SUBSUMED". - ---------------------- -getSwitchChecker :: SimplEnv -> SwitchChecker -getSwitchChecker env = seChkr env - ---------------------- -getMode :: SimplEnv -> SimplifierMode -getMode env = seMode env - -setMode :: SimplifierMode -> SimplEnv -> SimplEnv -setMode mode env = env { seMode = mode } - ---------------------- -getEnclosingCC :: SimplEnv -> CostCentreStack -getEnclosingCC env = seCC env - -setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv -setEnclosingCC env cc = env {seCC = cc} - ---------------------- -getSubst :: SimplEnv -> Subst -getSubst env = seSubst env - -getTvSubst :: SimplEnv -> TvSubst -getTvSubst env = Subst.getTvSubst (seSubst env) - -setTvSubstEnv :: SimplEnv -> TvSubstEnv -> SimplEnv -setTvSubstEnv env@(SimplEnv {seSubst = subst}) tv_subst_env - = env {seSubst = Subst.setTvSubstEnv subst tv_subst_env} - -setSubst :: SimplEnv -> Subst -> SimplEnv -setSubst env subst = env {seSubst = subst} - -extendIdSubst :: SimplEnv -> Id -> SubstResult -> SimplEnv -extendIdSubst env@(SimplEnv {seSubst = subst}) var res - = env {seSubst = Subst.extendIdSubst subst var res} - -extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv -extendTvSubst env@(SimplEnv {seSubst = subst}) var res - = env {seSubst = Subst.extendTvSubst subst var res} - ---------------------- -getInScope :: SimplEnv -> InScopeSet -getInScope env = substInScope (seSubst env) - -setInScope :: SimplEnv -> SimplEnv -> SimplEnv -setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope) - -setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv -setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope - = env {seSubst = Subst.setInScopeSet subst in_scope} - -addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv - -- The new Ids are guaranteed to be freshly allocated -addNewInScopeIds env@(SimplEnv {seSubst = subst}) vs - = env {seSubst = Subst.extendInScopeIds subst vs} - -modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv -modifyInScope env@(SimplEnv {seSubst = subst}) v v' - = env {seSubst = Subst.modifyInScope subst v v'} - ---------------------- -zapSubstEnv :: SimplEnv -> SimplEnv -zapSubstEnv env@(SimplEnv {seSubst = subst}) - = env {seSubst = Subst.zapSubstEnv subst} - -setSubstEnv :: SimplEnv -> Subst -> SimplEnv -setSubstEnv env@(SimplEnv {seSubst = subst}) subst_with_env - = env {seSubst = Subst.setSubstEnv subst subst_with_env} -\end{code} - - -%************************************************************************ -%* * -\subsection{Decisions about inlining} -%* * -%************************************************************************ - -Inlining is controlled partly by the SimplifierMode switch. This has two -settings: - - SimplGently (a) Simplifying before specialiser/full laziness - (b) Simplifiying inside INLINE pragma - (c) Simplifying the LHS of a rule - (d) Simplifying a GHCi expression or Template - Haskell splice - - SimplPhase n Used at all other times - -The key thing about SimplGently is that it does no call-site inlining. -Before full laziness we must be careful not to inline wrappers, -because doing so inhibits floating - e.g. ...(case f x of ...)... - ==> ...(case (case x of I# x# -> fw x#) of ...)... - ==> ...(case x of I# x# -> case fw x# of ...)... -and now the redex (f x) isn't floatable any more. - -The no-inling thing is also important for Template Haskell. You might be -compiling in one-shot mode with -O2; but when TH compiles a splice before -running it, we don't want to use -O2. Indeed, we don't want to inline -anything, because the byte-code interpreter might get confused about -unboxed tuples and suchlike. - -INLINE pragmas -~~~~~~~~~~~~~~ -SimplGently is also used as the mode to simplify inside an InlineMe note. - -\begin{code} -inlineMode :: SimplifierMode -inlineMode = SimplGently -\end{code} - -It really is important to switch off inlinings inside such -expressions. Consider the following example - - let f = \pq -> BIG - in - let g = \y -> f y y - {-# INLINE g #-} - in ...g...g...g...g...g... - -Now, if that's the ONLY occurrence of f, it will be inlined inside g, -and thence copied multiple times when g is inlined. - - -This function may be inlinined in other modules, so we -don't want to remove (by inlining) calls to functions that have -specialisations, or that may have transformation rules in an importing -scope. - -E.g. {-# INLINE f #-} - f x = ...g... - -and suppose that g is strict *and* has specialisations. If we inline -g's wrapper, we deny f the chance of getting the specialised version -of g when f is inlined at some call site (perhaps in some other -module). - -It's also important not to inline a worker back into a wrapper. -A wrapper looks like - wraper = inline_me (\x -> ...worker... ) -Normally, the inline_me prevents the worker getting inlined into -the wrapper (initially, the worker's only call site!). But, -if the wrapper is sure to be called, the strictness analyser will -mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf -continuation. That's why the keep_inline predicate returns True for -ArgOf continuations. It shouldn't do any harm not to dissolve the -inline-me note under these circumstances. - -Note that the result is that we do very little simplification -inside an InlineMe. - - all xs = foldr (&&) True xs - any p = all . map p {-# INLINE any #-} - -Problem: any won't get deforested, and so if it's exported and the -importer doesn't use the inlining, (eg passes it as an arg) then we -won't get deforestation at all. We havn't solved this problem yet! - - -preInlineUnconditionally -~~~~~~~~~~~~~~~~~~~~~~~~ -@preInlineUnconditionally@ examines a bndr to see if it is used just -once in a completely safe way, so that it is safe to discard the -binding inline its RHS at the (unique) usage site, REGARDLESS of how -big the RHS might be. If this is the case we don't simplify the RHS -first, but just inline it un-simplified. - -This is much better than first simplifying a perhaps-huge RHS and then -inlining and re-simplifying it. Indeed, it can be at least quadratically -better. Consider - - x1 = e1 - x2 = e2[x1] - x3 = e3[x2] - ...etc... - xN = eN[xN-1] - -We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc. - -NB: we don't even look at the RHS to see if it's trivial -We might have - x = y -where x is used many times, but this is the unique occurrence of y. -We should NOT inline x at all its uses, because then we'd do the same -for y -- aargh! So we must base this pre-rhs-simplification decision -solely on x's occurrences, not on its rhs. - -Evne RHSs labelled InlineMe aren't caught here, because there might be -no benefit from inlining at the call site. - -[Sept 01] Don't unconditionally inline a top-level thing, because that -can simply make a static thing into something built dynamically. E.g. - x = (a,b) - main = \s -> h x - -[Remember that we treat \s as a one-shot lambda.] No point in -inlining x unless there is something interesting about the call site. - -But watch out: if you aren't careful, some useful foldr/build fusion -can be lost (most notably in spectral/hartel/parstof) because the -foldr didn't see the build. Doing the dynamic allocation isn't a big -deal, in fact, but losing the fusion can be. But the right thing here -seems to be to do a callSiteInline based on the fact that there is -something interesting about the call site (it's strict). Hmm. That -seems a bit fragile. - -Conclusion: inline top level things gaily until Phase 0 (the last -phase), at which point don't. - -\begin{code} -preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool -preInlineUnconditionally env top_lvl bndr - | isTopLevel top_lvl, SimplPhase 0 <- phase = False --- If we don't have this test, consider --- x = length [1,2,3] --- The full laziness pass carefully floats all the cons cells to --- top level, and preInlineUnconditionally floats them all back in. --- Result is (a) static allocation replaced by dynamic allocation --- (b) many simplifier iterations because this tickles --- a related problem; only one inlining per pass --- --- On the other hand, I have seen cases where top-level fusion is --- lost if we don't inline top level thing (e.g. string constants) --- Hence the test for phase zero (which is the phase for all the final --- simplifications). Until phase zero we take no special notice of --- top level things, but then we become more leery about inlining --- them. - - | not active = False - | opt_SimplNoPreInlining = False - | otherwise = case idOccInfo bndr of - IAmDead -> True -- Happens in ((\x.1) v) - OneOcc in_lam once -> not in_lam && once - -- Not inside a lambda, one occurrence ==> safe! - other -> False - 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} @@ -945,29 +437,6 @@ activeRule env %************************************************************************ \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 @@ -1015,6 +484,29 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier* || 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} diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 960ab45..3ba53e0 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -5,9 +5,11 @@ \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(..), @@ -20,7 +22,9 @@ module SimplUtils ( #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 ) @@ -29,9 +33,9 @@ import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, 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 @@ -45,6 +49,8 @@ import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon ) 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} @@ -421,66 +427,272 @@ canUpdateInPlace ty %************************************************************************ %* * -\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} + %************************************************************************ %* * diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 0f0616e..7ffdc38 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -12,12 +12,14 @@ import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings), 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, @@ -49,11 +51,9 @@ import Rules ( lookupRule ) 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, @@ -234,7 +234,7 @@ simplTopBinds env binds -- 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) @@ -301,7 +301,7 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside 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 @@ -314,7 +314,7 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside 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 @@ -361,7 +361,7 @@ simplNonRecX env bndr new_rhs 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') -> @@ -423,7 +423,7 @@ simplRecOrTopPair :: SimplEnv 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 @@ -486,7 +486,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se -- 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 @@ -704,7 +704,7 @@ might do the same again. 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. @@ -743,10 +743,10 @@ simplExprF env (Case scrut bndr case_ty alts) cont 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 @@ -766,7 +766,7 @@ simplType :: SimplEnv -> InType -> SimplM OutType simplType env ty = seqType new_ty `seq` returnSmpl new_ty where - new_ty = substTy (getTvSubst env) ty + new_ty = substTy env ty \end{code} @@ -864,8 +864,8 @@ simplNote env (Coerce to from) body cont -- 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) @@ -911,10 +911,10 @@ simplNote env (CoreNote s) e 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 @@ -966,9 +966,10 @@ completeCall env var occ_info cont 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) -> @@ -1499,13 +1500,12 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont' 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') -> @@ -1514,7 +1514,7 @@ simplAlt env handled_cons case_bndr' (DataAlt con, vs, rhs) cont' 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 @@ -1611,7 +1611,7 @@ knownCon env con args bndr alts cont 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 -> diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 8bd967b..67e68a8 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -21,7 +21,7 @@ import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) 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 @@ -404,11 +404,17 @@ addIdSpecialisations id rules %************************************************************************ \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} diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 2863348..980db08 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -14,10 +14,9 @@ import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, 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 @@ -27,7 +26,7 @@ import CoreUtils ( applyTypeToArgs, mkPiTypes ) 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, @@ -596,7 +595,7 @@ specProgram dflags us binds -- 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) -> @@ -612,9 +611,7 @@ specProgram dflags us binds \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: @@ -655,7 +652,7 @@ specExpr subst e@(Lam _ _) 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 @@ -664,7 +661,7 @@ specExpr subst (Case scrut case_bndr ty alts) 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) @@ -674,7 +671,7 @@ specExpr subst (Case scrut case_bndr ty alts) 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) @@ -1013,7 +1010,7 @@ mkCallUDs subst f args -- *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 @@ -1144,20 +1141,20 @@ cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind) 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 -> diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index f4f020b..f2f06c8 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -1174,7 +1174,8 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var -- -- 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 @@ -1182,7 +1183,8 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var -- 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 -- 1.7.10.4