+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
-\section[SimplMonad]{The simplifier Monad}
-
-\begin{code}
-module SimplEnv (
- InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
- OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
-
- -- The simplifier mode
- setMode, getMode,
-
- -- Switch checker
- SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
- isAmongSimpl, intSwitchSet, switchIsOn,
-
- setEnclosingCC, getEnclosingCC,
-
- -- Environments
- SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst,
- zapSubstEnv, setSubstEnv,
- getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
- getRules, refineSimplEnv,
-
- SimplSR(..), mkContEx, substId,
-
- simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
- simplBinder, simplBinders, addLetIdInfo,
- substExpr, substTy,
-
- -- Floats
- FloatsWith, FloatsWithExpr,
- Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
- allLifted, wrapFloats, floatBinds,
- addAuxiliaryBind,
- ) where
-
-#include "HsVersions.h"
-
-import SimplMonad
-import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
-import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
- arityInfo, setArityInfo, workerInfo, setWorkerInfo,
- unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo,
- unknownArity, workerExists
- )
-import CoreSyn
-import Unify ( TypeRefinement )
-import Rules ( RuleBase )
-import CoreUtils ( needsCaseBinding )
-import CostCentre ( CostCentreStack, subsumedCCS )
-import Var
-import VarEnv
-import VarSet ( isEmptyVarSet )
-import OrdList
-
-import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker )
-import qualified Type ( substTy, substTyVarBndr )
-
-import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
- isUnLiftedType, seqType, tyVarsOfType )
-import BasicTypes ( OccInfo(..), isFragileOcc )
-import DynFlags ( SimplifierMode(..) )
-import Util ( mapAccumL )
-import Outputable
-\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? Consider
- -- let x = a*b in (x, \x -> x+3)
- -- We add [x |-> a*b] to the substitution, but we must
- -- *delete* it from the substitution when going inside
- -- the (\x -> ...)!
-
-modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
-modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
- = 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}
-
- GADT stuff
-
-Given an idempotent substitution, generated by the unifier, use it to
-refine the environment
-
-\begin{code}
-refineSimplEnv :: SimplEnv -> TypeRefinement -> SimplEnv
--- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes
-refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope })
- (refine_tv_subst, all_bound_here)
- = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst,
- seInScope = in_scope' }
- where
- in_scope'
- | all_bound_here = in_scope
- -- The tvs are the tyvars bound here. If only they
- -- are refined, there's no need to do anything
- | otherwise = mapInScopeSet refine_id in_scope
-
- refine_id v -- Only refine its type; any rules will get
- -- refined if they are used (I hope)
- | isId v = setIdType v (Type.substTy refine_subst (idType v))
- | otherwise = v
- refine_subst = TvSubst in_scope refine_tv_subst
-\end{code}
-
-%************************************************************************
-%* *
- 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
- :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplBinders env bndrs = mapAccumLSmpl simplBinder env bndrs
-simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr 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 env bndr
- ; 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 env bndr
- id2 = id1 `setIdUnfolding` substUnfolding env old_unf
-
---------------
-substIdBndr :: SimplEnv -> Id -- Substitition and Id to transform
- -> (SimplEnv, Id) -- Transformed pair
-
--- Returns with:
--- * Unique changed if necessary
--- * Type substituted
--- * Unfolding zapped
--- * Rules, worker, lbvar info all substituted
--- * Fragile occurrence info zapped
--- * The in-scope set extended with the returned Id
--- * The substitution extended with a DoneId if unique changed
--- In this case, the var in the DoneId is the same as the
--- var returned
-
-substIdBndr 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 final IdInfo
- subst = mkCoreSubst env
- new_id = maybeModifyIdInfo (substIdInfo subst) id2
-
- -- Extend the substitution if the unique has changed
- -- See the notes with substTyVarBndr for the delSubstEnv
- new_subst | new_id /= old_id
- = extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id))
- | otherwise
- = delVarEnv id_subst old_id
-\end{code}
-
-
-\begin{code}
-seqTyVar :: TyVar -> ()
-seqTyVar b = b `seq` ()
-
-seqId :: Id -> ()
-seqId id = seqType (idType id) `seq`
- idInfo id `seq`
- ()
-
-seqIds :: [Id] -> ()
-seqIds [] = ()
-seqIds (id:ids) = seqId id `seq` seqIds ids
-\end{code}
-
-
-%************************************************************************
-%* *
- Let bindings
-%* *
-%************************************************************************
-
-Simplifying let binders
-~~~~~~~~~~~~~~~~~~~~~~~
-Rename the binders if necessary,
-
-\begin{code}
-simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
-simplNonRecBndr env id
- = do { let (env1, id1) = substLetIdBndr env id
- ; seqId id1 `seq` return (env1, id1) }
-
----------------
-simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
- = do { let (env1, ids1) = mapAccumL substLetIdBndr env ids
- ; seqIds ids1 `seq` return (env1, ids1) }
-
----------------
-substLetIdBndr :: SimplEnv -> InBinder -- Env and binder to transform
- -> (SimplEnv, OutBinder)
--- C.f. CoreSubst.substIdBndr
--- Clone Id if necessary, substitute its type
--- Return an Id with completely zapped IdInfo
--- [addLetIdInfo, below, will restore its IdInfo]
--- Augment the subtitution
--- if the unique changed, *or*
--- if there's interesting occurrence info
-
-substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
- = (env { seInScope = in_scope `extendInScopeSet` new_id,
- seIdSubst = new_subst }, new_id)
- where
- 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 (idInfo old_id)
- new_subst | new_id /= old_id || isFragileOcc occ_info
- = extendVarEnv id_subst old_id (DoneId new_id occ_info)
- | otherwise
- = delVarEnv id_subst old_id
-\end{code}
-
-Add IdInfo back onto a let-bound Id
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must transfer the IdInfo of the original binder to the new binder.
-This is crucial, to preserve
- strictness
- rules
- worker info
-etc. To do this we must apply the current substitution,
-which incorporates earlier substitutions in this very letrec group.
-
-NB 1. We do this *before* processing the RHS of the binder, so that
-its substituted rules are visible in its own RHS.
-This is important. Manuel found cases where he really, really
-wanted a RULE for a recursive function to apply in that function's
-own right-hand side.
-
-NB 2: We do not transfer the arity (see Subst.substIdInfo)
-The arity of an Id should not be visible
-in its own RHS, else we eta-reduce
- f = \x -> f x
-to
- f = f
-which isn't sound. And it makes the arity in f's IdInfo greater than
-the manifest arity, which isn't good.
-The arity will get added later.
-
-NB 3: It's important that we *do* transer the loop-breaker OccInfo,
-because that's what stops the Id getting inlined infinitely, in the body
-of the letrec.
-
-NB 4: does no harm for non-recursive bindings
-
-NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
- rec { f = g
- h = ...
- RULE h Int = f
- }
-Here, we'll do postInlineUnconditionally on f, and we must "see" that
-when substituting in h's RULE.
-
-\begin{code}
-addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder)
-addLetIdInfo env in_id out_id
- = (modifyInScope env out_id out_id, final_id)
- where
- final_id = out_id `setIdInfo` new_info
- subst = mkCoreSubst env
- old_info = idInfo in_id
- new_info = case substIdInfo subst old_info of
- Nothing -> old_info
- Just new_info -> new_info
-
-substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
--- Substitute the
--- rules
--- worker info
--- Zap the unfolding
--- Keep only 'robust' OccInfo
--- Zap Arity
---
--- Seq'ing on the returned IdInfo is enough to cause all the
--- substitutions to happen completely
-
-substIdInfo subst info
- | nothing_to_do = Nothing
- | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo)
- `setArityInfo` (if keep_arity then old_arity else unknownArity)
- `setSpecInfo` CoreSubst.substSpec subst old_rules
- `setWorkerInfo` CoreSubst.substWorker subst old_wrkr
- `setUnfoldingInfo` noUnfolding)
- -- setSpecInfo does a seq
- -- setWorkerInfo does a seq
- where
- nothing_to_do = keep_occ && keep_arity &&
- isEmptySpecInfo old_rules &&
- not (workerExists old_wrkr) &&
- not (hasUnfolding (unfoldingInfo info))
-
- keep_occ = not (isFragileOcc old_occ)
- keep_arity = 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}
-
-
-%************************************************************************
-%* *
- Impedence matching to type substitution
-%* *
-%************************************************************************
-
-\begin{code}
-substTy :: SimplEnv -> Type -> Type
-substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
- = Type.substTy (TvSubst in_scope tv_env) ty
-
-substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
-substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
- = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
- (TvSubst in_scope' tv_env', tv')
- -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
-
--- When substituting in rules etc we can get CoreSubst to do the work
--- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
--- here. I think the this will not usually result in a lot of work;
--- the substitutions are typically small, and laziness will avoid work in many cases.
-
-mkCoreSubst :: SimplEnv -> CoreSubst.Subst
-mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
- = mk_subst tv_env id_env
- where
- mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
-
- fiddle (DoneEx e) = e
- fiddle (DoneId v occ) = Var v
- fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
-
-substExpr :: SimplEnv -> CoreExpr -> CoreExpr
-substExpr env expr
- | isEmptySimplSubst env = expr
- | otherwise = CoreSubst.substExpr (mkCoreSubst env) expr
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Floats}
-%* *
-%************************************************************************
-
-\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}
-
-
projects / ghc-hetmet.git / blobdiff