bindSubst, unBindSubst, bindSubstList, unBindSubstList,
-- Binders
- substBndr, substBndrs, substTyVar, substId, substIds,
- substAndCloneId, substAndCloneIds,
+ simplBndr, simplBndrs, simplLetId, simplIdInfo,
+ substAndCloneId, substAndCloneIds, substAndCloneRecIds,
-- Type stuff
mkTyVarSubst, mkTopTyVarSubst,
import CmdLineOpts ( opt_PprStyle_Debug )
import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
CoreRules(..), CoreRule(..),
- isEmptyCoreRules, seqRules
+ isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding
)
import CoreFVs ( exprFreeVars, mustHaveLocalBinding )
import TypeRep ( Type(..), TyNote(..) ) -- friend
import VarSet
import VarEnv
import Var ( setVarUnique, isId )
-import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo, maybeModifyIdInfo )
-import IdInfo ( IdInfo, isFragileOcc,
- specInfo, setSpecInfo,
+import Id ( idType, idInfo, setIdInfo, setIdType, idOccInfo, maybeModifyIdInfo )
+import IdInfo ( IdInfo, mkIdInfo,
+ occInfo, isFragileOcc, setOccInfo,
+ specInfo, setSpecInfo, flavourInfo,
+ unfoldingInfo, setUnfoldingInfo,
+ CafInfo(NoCafRefs),
WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo,
- lbvarInfo, LBVarInfo(..), setLBVarInfo
+ lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo
)
-import Unique ( Uniquable(..), deriveUnique )
+import BasicTypes ( OccInfo(..) )
+import Unique ( Unique, Uniquable(..), deriveUnique )
import UniqSet ( elemUniqSet_Directly )
-import UniqSupply ( UniqSupply, uniqFromSupply, splitUniqSupply )
+import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply )
import Var ( Var, Id, TyVar, isTyVar )
import Outputable
import PprCore () -- Instances
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, but all its fragile IdInfo has been zapped.
- That is added back in later. So new_id is the minimal thing it's
- correct to substitute.
+ 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
go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
where
- (subst', bndrs') = substBndrs subst (map fst pairs)
+ (subst', bndrs') = substRecIds subst (map fst pairs)
pairs' = bndrs' `zip` rhss'
rhss' = map (substExpr subst' . snd) pairs
\end{code}
-Substituting in binders is a rather tricky part of the whole compiler.
-When we hit a binder we may need to
- (a) apply the the type envt (if non-empty) to its type
- (c) give it a new unique to avoid name clashes
+%************************************************************************
+%* *
+\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 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 = substTyVar subst bndr
+ | otherwise = subst_id isFragileOcc subst subst bndr
+
+simplBndrs :: Subst -> [Var] -> (Subst, [Var])
+simplBndrs subst bndrs = mapAccumL simplBndr subst bndrs
+
+simplLetId :: Subst -> Id -> (Subst, Id)
+-- Clone Id if necessary
+-- Substitute its type
+-- Return an Id with completely zapped IdInfo
+-- Augment the subtitution if the unique changed or if there's
+-- interesting occurrence info
+-- [A subsequent substIdInfo will restore its IdInfo]
+simplLetId subst@(Subst in_scope env) old_id
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
+ where
+ old_info = idInfo old_id
+ id1 = uniqAway in_scope old_id
+ id2 = substIdType subst id1
+ new_id = id2 `setIdInfo` mkIdInfo (flavourInfo old_info) NoCafRefs
+ -- Zap the IdIno altogether, but preserve the flavour
+
+ -- Extend the substitution if the unique has changed,
+ -- or there's some useful occurrence information
+ -- See the notes with substTyVar for the delSubstEnv
+ occ_info = occInfo old_info
+ new_env | new_id /= old_id || isFragileOcc occ_info
+ = extendSubstEnv env old_id (DoneId new_id occ_info)
+ | otherwise
+ = delSubstEnv env old_id
+
+simplIdInfo :: Subst -> IdInfo -> Id -> Id
+ -- Used by the simplifier to compute new IdInfo for a let(rec) binder,
+ -- subsequent to simplLetId having zapped its IdInfo
+simplIdInfo subst old_info bndr
+ = case substIdInfo subst isFragileOcc old_info of
+ Just new_info -> bndr `setIdInfo` new_info
+ Nothing -> bndr `setIdInfo` 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. Hence the calls to
+-- simpl_id with keepOccInfo
+
substBndr :: Subst -> Var -> (Subst, Var)
substBndr subst bndr
| isTyVar bndr = substTyVar subst bndr
- | otherwise = substId subst bndr
+ | otherwise = subst_id keepOccInfo subst subst bndr
substBndrs :: Subst -> [Var] -> (Subst, [Var])
substBndrs subst bndrs = mapAccumL substBndr subst bndrs
+substRecIds :: Subst -> [Id] -> (Subst, [Id])
+-- Substitute a mutually recursive group
+substRecIds 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 keepOccInfo new_subst) subst bndrs
-substIds :: Subst -> [Id] -> (Subst, [Id])
-substIds subst bndrs = mapAccumL substId subst bndrs
+keepOccInfo occ = False -- Never fragile
+\end{code}
-substId :: Subst -> Id -> (Subst, Id)
- -- Returns an Id with empty IdInfo
- -- See the notes with the Subst data type decl at the
- -- top of this module
-substId subst@(Subst in_scope env) old_id
+\begin{code}
+subst_id :: (OccInfo -> Bool) -- True <=> the OccInfo is fragile
+ -> 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 is_fragile_occ rec_subst subst@(Subst in_scope env) old_id
= (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
where
- id_ty = idType old_id
- occ_info = idOccInfo old_id
-
- -- id1 has its type zapped
- id1 | noTypeSubst env
- || isEmptyVarSet (tyVarsOfType id_ty) = old_id
- -- 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
- | otherwise = setIdType old_id (substTy subst id_ty)
-
- -- id2 has its IdInfo zapped
- id2 = zapFragileIdInfo id1
-
- -- id3 has its LBVarInfo zapped
- id3 = maybeModifyIdInfo (\ info -> go info (lbvarInfo info)) id2
- where go info (LBVarInfo u@(TyVarTy _)) = Just $ setLBVarInfo info $
- LBVarInfo (subst_ty subst u)
- go info _ = Nothing
-
- -- new_id is cloned if necessary
- new_id = uniqAway in_scope id3
- -- Extend the substitution if the unique has changed,
- -- or there's some useful occurrence information
+ -- 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 rec_subst is_fragile_occ) id2
+
+ -- Extend the substitution if the unique has changed
-- See the notes with substTyVar for the delSubstEnv
- new_env | new_id /= old_id || isFragileOcc occ_info
- = extendSubstEnv env old_id (DoneId new_id occ_info)
+ new_env | new_id /= old_id
+ = extendSubstEnv env old_id (DoneId new_id (idOccInfo old_id))
| otherwise
= delSubstEnv env old_id
\end{code}
Now a variant that unconditionally allocates a new unique.
+It also unconditionally zaps the OccInfo.
\begin{code}
-substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, UniqSupply, [Id])
-substAndCloneIds subst us [] = (subst, us, [])
-substAndCloneIds subst us (b:bs) = case substAndCloneId subst us b of { (subst1, us1, b') ->
- case substAndCloneIds subst1 us1 bs of { (subst2, us2, bs') ->
- (subst2, us2, (b':bs')) }}
-
-substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, UniqSupply, Id)
-substAndCloneId subst@(Subst in_scope env) us old_id
- = (Subst (in_scope `extendInScopeSet` new_id)
- (extendSubstEnv env old_id (DoneEx (Var new_id))),
- new_us,
- new_id)
+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) (old_id, uniq)
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
+ where
+ id1 = setVarUnique old_id uniq
+ id2 = substIdType subst id1
+
+ new_id = maybeModifyIdInfo (substIdInfo rec_subst isFragileOcc) id2
+ new_env = extendSubstEnv 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 (length ids) us)
+
+substAndCloneRecIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
+substAndCloneRecIds subst us ids
+ = (subst', ids')
where
- id_ty = idType old_id
- id1 | noTypeSubst env || isEmptyVarSet (tyVarsOfType id_ty) = old_id
- | otherwise = setIdType old_id (substTy subst id_ty)
+ (subst', ids') = mapAccumL (subst_clone_id subst') subst
+ (ids `zip` uniqsFromSupply (length ids) us)
- id2 = zapFragileIdInfo id1
- new_id = setVarUnique id2 (uniqFromSupply us1)
- (us1,new_us) = splitUniqSupply us
+substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
+substAndCloneId subst@(Subst in_scope env) us old_id
+ = subst_clone_id subst subst (old_id, uniqFromSupply us)
\end{code}
\begin{code}
substIdInfo :: Subst
- -> IdInfo -- Get un-substituted ones from here
- -> IdInfo -- Substitute it and add it to here
- -> IdInfo -- To give this
- -- Seq'ing on the returned IdInfo is enough to cause all the
- -- substitutions to happen completely
-
-substIdInfo subst old_info new_info
- = info2
- where
- info1 | isEmptyCoreRules old_rules = new_info
- | otherwise = new_info `setSpecInfo` new_rules
+ -> (OccInfo -> Bool) -- True <=> zap the occurrence info
+ -> IdInfo
+ -> Maybe IdInfo
+-- Substitute the
+-- rules
+-- worker info
+-- LBVar info
+-- Zap the unfolding
+-- Zap the occ info if instructed to do so
+--
+-- Seq'ing on the returned IdInfo is enough to cause all the
+-- substitutions to happen completely
+
+substIdInfo subst is_fragile_occ info
+ | nothing_to_do = Nothing
+ | otherwise = Just (info `setOccInfo` (if zap_occ then NoOccInfo else old_occ)
+ `setSpecInfo` substRules subst old_rules
+ `setWorkerInfo` substWorker subst old_wrkr
+ `setLBVarInfo` substLBVar subst old_lbv
+ `setUnfoldingInfo` noUnfolding)
-- setSpecInfo does a seq
- where
- new_rules = substRules subst old_rules
-
- info2 | not (workerExists old_wrkr) = info1
- | otherwise = info1 `setWorkerInfo` new_wrkr
-- setWorkerInfo does a seq
- where
- new_wrkr = substWorker subst old_wrkr
-
- old_rules = specInfo old_info
- old_wrkr = workerInfo old_info
+ where
+ nothing_to_do = not zap_occ &&
+ isEmptyCoreRules old_rules &&
+ not (workerExists old_wrkr) &&
+ hasNoLBVarInfo old_lbv &&
+ not (hasUnfolding (unfoldingInfo info))
+
+ zap_occ = is_fragile_occ old_occ
+ old_occ = occInfo info
+ old_rules = specInfo info
+ old_wrkr = workerInfo info
+ old_lbv = lbvarInfo info
+
+substIdType :: Subst -> Id -> Id
+substIdType subst@(Subst in_scope env) id
+ | noTypeSubst 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
substWorker :: Subst -> WorkerInfo -> WorkerInfo
-- Seq'ing on the returned WorkerInfo is enough to cause all the
DoneEx expr -> exprFreeVars expr
DoneTy ty -> tyVarsOfType ty
ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
+
+substLBVar subst NoLBVarInfo = NoLBVarInfo
+substLBVar subst (LBVarInfo ty) = ty1 `seq` LBVarInfo ty1
+ where
+ ty1 = substTy subst ty
\end{code}
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section{SetLevels}
-
- ***************************
- Overview
- ***************************
-
-1. We attach binding levels to Core bindings, in preparation for floating
- outwards (@FloatOut@).
-
-2. We also let-ify many expressions (notably case scrutinees), so they
- will have a fighting chance of being floated sensible.
-
-3. We clone the binders of any floatable let-binding, so that when it is
- floated out it will be unique. (This used to be done by the simplifier
- but the latter now only ensures that there's no shadowing; indeed, even
- that may not be true.)
-
- NOTE: this can't be done using the uniqAway idea, because the variable
- must be unique in the whole program, not just its current scope,
- because two variables in different scopes may float out to the
- same top level place
-
- NOTE: Very tiresomely, we must apply this substitution to
- the rules stored inside a variable too.
-
- We do *not* clone top-level bindings, because some of them must not change,
- but we *do* clone bindings that are heading for the top level
-
-4. In the expression
- case x of wild { p -> ...wild... }
- we substitute x for wild in the RHS of the case alternatives:
- case x of wild { p -> ...x... }
- This means that a sub-expression involving x is not "trapped" inside the RHS.
- And it's not inconvenient because we already have a substitution.
-
- Note that this is EXACTLY BACKWARDS from the what the simplifier does.
- The simplifier tries to get rid of occurrences of x, in favour of wild,
- in the hope that there will only be one remaining occurrence of x, namely
- the scrutinee of the case, and we can inline it.
-
-\begin{code}
-module SetLevels (
- setLevels,
-
- Level(..), tOP_LEVEL,
-
- incMinorLvl, ltMajLvl, ltLvl, isTopLvl
- ) where
-
-#include "HsVersions.h"
-
-import CoreSyn
-
-import CoreUtils ( exprType, exprIsTrivial, exprIsBottom, mkPiType )
-import CoreFVs -- all of it
-import Subst
-import Id ( Id, idType, mkSysLocal, isOneShotLambda, modifyIdInfo,
- idSpecialisation, idWorkerInfo, setIdInfo
- )
-import IdInfo ( workerExists, vanillaIdInfo, demandInfo, setDemandInfo )
-import Var ( Var, setVarUnique )
-import VarSet
-import VarEnv
-import Name ( getOccName )
-import OccName ( occNameUserString )
-import Type ( isUnLiftedType, Type )
-import BasicTypes ( TopLevelFlag(..) )
-import Demand ( isStrict, wwLazy )
-import UniqSupply
-import Util ( sortLt, isSingleton, count )
-import Outputable
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Level numbers}
-%* *
-%************************************************************************
-
-\begin{code}
-data Level = Level Int -- Level number of enclosing lambdas
- Int -- Number of big-lambda and/or case expressions between
- -- here and the nearest enclosing lambda
-\end{code}
-
-The {\em level number} on a (type-)lambda-bound variable is the
-nesting depth of the (type-)lambda which binds it. The outermost lambda
-has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
-
-On an expression, it's the maximum level number of its free
-(type-)variables. On a let(rec)-bound variable, it's the level of its
-RHS. On a case-bound variable, it's the number of enclosing lambdas.
-
-Top-level variables: level~0. Those bound on the RHS of a top-level
-definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
-as ``subscripts'')...
-\begin{verbatim}
-a_0 = let b_? = ... in
- x_1 = ... b ... in ...
-\end{verbatim}
-
-The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
-That's meant to be the level number of the enclosing binder in the
-final (floated) program. If the level number of a sub-expression is
-less than that of the context, then it might be worth let-binding the
-sub-expression so that it will indeed float. This context level starts
-at @Level 0 0@.
-
-\begin{code}
-type LevelledExpr = TaggedExpr Level
-type LevelledBind = TaggedBind Level
-
-tOP_LEVEL = Level 0 0
-
-incMajorLvl :: Level -> Level
-incMajorLvl (Level major minor) = Level (major+1) 0
-
-incMinorLvl :: Level -> Level
-incMinorLvl (Level major minor) = Level major (minor+1)
-
-maxLvl :: Level -> Level -> Level
-maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
- | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
- | otherwise = l2
-
-ltLvl :: Level -> Level -> Bool
-ltLvl (Level maj1 min1) (Level maj2 min2)
- = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
-
-ltMajLvl :: Level -> Level -> Bool
- -- Tells if one level belongs to a difft *lambda* level to another
-ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
-
-isTopLvl :: Level -> Bool
-isTopLvl (Level 0 0) = True
-isTopLvl other = False
-
-instance Outputable Level where
- ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
-
-instance Eq Level where
- (Level maj1 min1) == (Level maj2 min2) = maj1==maj2 && min1==min2
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Main level-setting code}
-%* *
-%************************************************************************
-
-\begin{code}
-setLevels :: Bool -- True <=> float lambdas to top level
- -> [CoreBind]
- -> UniqSupply
- -> [LevelledBind]
-
-setLevels float_lams binds us
- = initLvl us (do_them binds)
- where
- -- "do_them"'s main business is to thread the monad along
- -- It gives each top binding the same empty envt, because
- -- things unbound in the envt have level number zero implicitly
- do_them :: [CoreBind] -> LvlM [LevelledBind]
-
- do_them [] = returnLvl []
- do_them (b:bs)
- = lvlTopBind init_env b `thenLvl` \ (lvld_bind, _) ->
- do_them bs `thenLvl` \ lvld_binds ->
- returnLvl (lvld_bind : lvld_binds)
-
- init_env = initialEnv float_lams
-
-lvlTopBind env (NonRec binder rhs)
- = lvlBind TopLevel tOP_LEVEL env (AnnNonRec binder (freeVars rhs))
- -- Rhs can have no free vars!
-
-lvlTopBind env (Rec pairs)
- = lvlBind TopLevel tOP_LEVEL env (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Setting expression levels}
-%* *
-%************************************************************************
-
-\begin{code}
-lvlExpr :: Level -- ctxt_lvl: Level of enclosing expression
- -> LevelEnv -- Level of in-scope names/tyvars
- -> CoreExprWithFVs -- input expression
- -> LvlM LevelledExpr -- Result expression
-\end{code}
-
-The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
-binder. Here's an example
-
- v = \x -> ...\y -> let r = case (..x..) of
- ..x..
- in ..
-
-When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
-the level of @r@, even though it's inside a level-2 @\y@. It's
-important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
-don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
---- because it isn't a *maximal* free expression.
-
-If there were another lambda in @r@'s rhs, it would get level-2 as well.
-
-\begin{code}
-lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty)
-lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v)
-lvlExpr _ env (_, AnnLit lit) = returnLvl (Lit lit)
-
-lvlExpr ctxt_lvl env (_, AnnApp fun arg)
- = lvl_fun fun `thenLvl` \ fun' ->
- lvlMFE False ctxt_lvl env arg `thenLvl` \ arg' ->
- returnLvl (App fun' arg')
- where
- lvl_fun (_, AnnCase _ _ _) = lvlMFE True ctxt_lvl env fun
- lvl_fun other = lvlExpr ctxt_lvl env fun
- -- We don't do MFE on partial applications generally,
- -- but we do if the function is big and hairy, like a case
-
-lvlExpr ctxt_lvl env (_, AnnNote InlineMe expr)
--- Don't float anything out of an InlineMe; hence the tOP_LEVEL
- = lvlExpr tOP_LEVEL env expr `thenLvl` \ expr' ->
- returnLvl (Note InlineMe expr')
-
-lvlExpr ctxt_lvl env (_, AnnNote note expr)
- = lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
- returnLvl (Note note expr')
-
--- We don't split adjacent lambdas. That is, given
--- \x y -> (x+1,y)
--- we don't float to give
--- \x -> let v = x+y in \y -> (v,y)
--- Why not? Because partial applications are fairly rare, and splitting
--- lambdas makes them more expensive.
-
-lvlExpr ctxt_lvl env expr@(_, AnnLam bndr rhs)
- = lvlMFE True new_lvl new_env body `thenLvl` \ new_body ->
- returnLvl (glue_binders new_bndrs expr new_body)
- where
- (bndrs, body) = collect_binders expr
- (new_lvl, new_bndrs) = lvlLamBndrs ctxt_lvl bndrs
- new_env = extendLvlEnv env new_bndrs
-
-lvlExpr ctxt_lvl env (_, AnnLet bind body)
- = lvlBind NotTopLevel ctxt_lvl env bind `thenLvl` \ (bind', new_env) ->
- lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
- returnLvl (Let bind' body')
-
-lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
- = lvlMFE True ctxt_lvl env expr `thenLvl` \ expr' ->
- let
- alts_env = extendCaseBndrLvlEnv env expr' case_bndr incd_lvl
- in
- mapLvl (lvl_alt alts_env) alts `thenLvl` \ alts' ->
- returnLvl (Case expr' (case_bndr, incd_lvl) alts')
- where
- incd_lvl = incMinorLvl ctxt_lvl
-
- lvl_alt alts_env (con, bs, rhs)
- = lvlMFE True incd_lvl new_env rhs `thenLvl` \ rhs' ->
- returnLvl (con, bs', rhs')
- where
- bs' = [ (b, incd_lvl) | b <- bs ]
- new_env = extendLvlEnv alts_env bs'
-
-collect_binders lam
- = go [] lam
- where
- go rev_bndrs (_, AnnLam b e) = go (b:rev_bndrs) e
- go rev_bndrs (_, AnnNote n e) = go rev_bndrs e
- go rev_bndrs rhs = (reverse rev_bndrs, rhs)
- -- Ignore notes, because we don't want to split
- -- a lambda like this (\x -> coerce t (\s -> ...))
- -- This happens quite a bit in state-transformer programs
-
- -- glue_binders puts the lambda back together
-glue_binders (b:bs) (_, AnnLam _ e) body = Lam b (glue_binders bs e body)
-glue_binders bs (_, AnnNote n e) body = Note n (glue_binders bs e body)
-glue_binders [] e body = body
-\end{code}
-
-@lvlMFE@ is just like @lvlExpr@, except that it might let-bind
-the expression, so that it can itself be floated.
-
-\begin{code}
-lvlMFE :: Bool -- True <=> strict context [body of case or let]
- -> Level -- Level of innermost enclosing lambda/tylam
- -> LevelEnv -- Level of in-scope names/tyvars
- -> CoreExprWithFVs -- input expression
- -> LvlM LevelledExpr -- Result expression
-
-lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty)
- = returnLvl (Type ty)
-
-lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
- | isUnLiftedType ty -- Can't let-bind it
- || not good_destination
- || exprIsTrivial expr -- Is trivial
- || (strict_ctxt && exprIsBottom expr) -- Strict context and is bottom
- -- e.g. \x -> error "foo"
- -- No gain from floating this
- = -- Don't float it out
- lvlExpr ctxt_lvl env ann_expr
-
- | otherwise -- Float it out!
- = lvlFloatRhs abs_vars dest_lvl env ann_expr `thenLvl` \ expr' ->
- newLvlVar "lvl" abs_vars ty `thenLvl` \ var ->
- returnLvl (Let (NonRec (var,dest_lvl) expr')
- (mkVarApps (Var var) abs_vars))
- where
- expr = deAnnotate ann_expr
- ty = exprType expr
- dest_lvl = destLevel env fvs (isFunction ann_expr)
- abs_vars = abstractVars dest_lvl env fvs
-
- good_destination = dest_lvl `ltMajLvl` ctxt_lvl -- Escapes a value lambda
- || (isTopLvl dest_lvl && not strict_ctxt) -- Goes to the top
- -- A decision to float entails let-binding this thing, and we only do
- -- that if we'll escape a value lambda, or will go to the top level.
- -- But beware
- -- concat = /\ a -> foldr ..a.. (++) []
- -- was getting turned into
- -- concat = /\ a -> lvl a
- -- lvl = /\ a -> foldr ..a.. (++) []
- -- which is pretty stupid. Hence the strict_ctxt test
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Bindings}
-%* *
-%************************************************************************
-
-The binding stuff works for top level too.
-
-\begin{code}
-lvlBind :: TopLevelFlag -- Used solely to decide whether to clone
- -> Level -- Context level; might be Top even for bindings nested in the RHS
- -- of a top level binding
- -> LevelEnv
- -> CoreBindWithFVs
- -> LvlM (LevelledBind, LevelEnv)
-
-lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
- | null abs_vars
- = -- No type abstraction; clone existing binder
- lvlExpr dest_lvl env rhs `thenLvl` \ rhs' ->
- cloneVar top_lvl env bndr ctxt_lvl dest_lvl `thenLvl` \ (env', bndr') ->
- returnLvl (NonRec (bndr', dest_lvl) rhs', env')
-
- | otherwise
- = -- Yes, type abstraction; create a new binder, extend substitution, etc
- lvlFloatRhs abs_vars dest_lvl env rhs `thenLvl` \ rhs' ->
- newPolyBndrs dest_lvl env abs_vars [bndr] `thenLvl` \ (env', [bndr']) ->
- returnLvl (NonRec (bndr', dest_lvl) rhs', env')
-
- where
- bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr
- abs_vars = abstractVars dest_lvl env bind_fvs
-
- dest_lvl | isUnLiftedType (idType bndr) = destLevel env bind_fvs False `maxLvl` Level 1 0
- | otherwise = destLevel env bind_fvs (isFunction rhs)
- -- Hack alert! We do have some unlifted bindings, for cheap primops, and
- -- it is ok to float them out; but not to the top level. If they would otherwise
- -- go to the top level, we pin them inside the topmost lambda
-\end{code}
-
-
-\begin{code}
-lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
- | null abs_vars
- = cloneVars top_lvl env bndrs ctxt_lvl dest_lvl `thenLvl` \ (new_env, new_bndrs) ->
- mapLvl (lvlExpr ctxt_lvl new_env) rhss `thenLvl` \ new_rhss ->
- returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
-
- | isSingleton pairs && count isId abs_vars > 1
- = -- Special case for self recursion where there are
- -- several variables carried around: build a local loop:
- -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars
- -- This just makes the closures a bit smaller. If we don't do
- -- this, allocation rises significantly on some programs
- --
- -- We could elaborate it for the case where there are several
- -- mutually functions, but it's quite a bit more complicated
- --
- -- This all seems a bit ad hoc -- sigh
- let
- (bndr,rhs) = head pairs
- (rhs_lvl, abs_vars_w_lvls) = lvlLamBndrs dest_lvl abs_vars
- rhs_env = extendLvlEnv env abs_vars_w_lvls
- in
- cloneVar NotTopLevel rhs_env bndr rhs_lvl rhs_lvl `thenLvl` \ (rhs_env', new_bndr) ->
- let
- (lam_bndrs, rhs_body) = collect_binders rhs
- (body_lvl, new_lam_bndrs) = lvlLamBndrs rhs_lvl lam_bndrs
- body_env = extendLvlEnv rhs_env' new_lam_bndrs
- in
- lvlExpr body_lvl body_env rhs_body `thenLvl` \ new_rhs_body ->
- newPolyBndrs dest_lvl env abs_vars [bndr] `thenLvl` \ (poly_env, [poly_bndr]) ->
- returnLvl (Rec [((poly_bndr,dest_lvl), mkLams abs_vars_w_lvls $
- glue_binders new_lam_bndrs rhs $
- Let (Rec [((new_bndr,rhs_lvl), mkLams new_lam_bndrs new_rhs_body)])
- (mkVarApps (Var new_bndr) lam_bndrs))],
- poly_env)
-
- | otherwise
- = newPolyBndrs dest_lvl env abs_vars bndrs `thenLvl` \ (new_env, new_bndrs) ->
- mapLvl (lvlFloatRhs abs_vars dest_lvl new_env) rhss `thenLvl` \ new_rhss ->
- returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
-
- where
- (bndrs,rhss) = unzip pairs
-
- -- Finding the free vars of the binding group is annoying
- bind_fvs = (unionVarSets [ idFreeVars bndr `unionVarSet` rhs_fvs
- | (bndr, (rhs_fvs,_)) <- pairs])
- `minusVarSet`
- mkVarSet bndrs
-
- dest_lvl = destLevel env bind_fvs (all isFunction rhss)
- abs_vars = abstractVars dest_lvl env bind_fvs
-
-----------------------------------------------------
--- Three help functons for the type-abstraction case
-
-lvlFloatRhs abs_vars dest_lvl env rhs
- = lvlExpr rhs_lvl rhs_env rhs `thenLvl` \ rhs' ->
- returnLvl (mkLams abs_vars_w_lvls rhs')
- where
- (rhs_lvl, abs_vars_w_lvls) = lvlLamBndrs dest_lvl abs_vars
- rhs_env = extendLvlEnv env abs_vars_w_lvls
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Deciding floatability}
-%* *
-%************************************************************************
-
-\begin{code}
-lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [(CoreBndr, Level)])
--- Compute the levels for the binders of a lambda group
--- The binders returned are exactly the same as the ones passed,
--- but they are now paired with a level
-lvlLamBndrs lvl []
- = (lvl, [])
-
-lvlLamBndrs lvl bndrs
- = go (incMinorLvl lvl)
- False -- Havn't bumped major level in this group
- [] bndrs
- where
- go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs)
- | isId bndr && -- Go to the next major level if this is a value binder,
- not bumped_major && -- and we havn't already gone to the next level (one jump per group)
- not (isOneShotLambda bndr) -- and it isn't a one-shot lambda
- = go new_lvl True ((bndr,new_lvl) : rev_lvld_bndrs) bndrs
-
- | otherwise
- = go old_lvl bumped_major ((bndr,old_lvl) : rev_lvld_bndrs) bndrs
-
- where
- new_lvl = incMajorLvl old_lvl
-
- go old_lvl _ rev_lvld_bndrs []
- = (old_lvl, reverse rev_lvld_bndrs)
- -- a lambda like this (\x -> coerce t (\s -> ...))
- -- This happens quite a bit in state-transformer programs
-\end{code}
-
-\begin{code}
-abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
- -- Find the variables in fvs, free vars of the target expresion,
- -- whose level is less than than the supplied level
- -- These are the ones we are going to abstract out
-abstractVars dest_lvl env fvs
- = uniq (sortLt lt [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
- where
- -- Sort the variables so we don't get
- -- mixed-up tyvars and Ids; it's just messy
- v1 `lt` v2 = case (isId v1, isId v2) of
- (True, False) -> False
- (False, True) -> True
- other -> v1 < v2 -- Same family
- uniq :: [Var] -> [Var]
- -- Remove adjacent duplicates; the sort will have brought them together
- uniq (v1:v2:vs) | v1 == v2 = uniq (v2:vs)
- | otherwise = v1 : uniq (v2:vs)
- uniq vs = vs
-
- -- Destintion level is the max Id level of the expression
- -- (We'll abstract the type variables, if any.)
-destLevel :: LevelEnv -> VarSet -> Bool -> Level
-destLevel env fvs is_function
- | floatLams env
- && is_function = tOP_LEVEL -- Send functions to top level; see
- -- the comments with isFunction
- | otherwise = maxIdLevel env fvs
-
-isFunction :: CoreExprWithFVs -> Bool
--- The idea here is that we want to float *functions* to
--- the top level. This saves no work, but
--- (a) it can make the host function body a lot smaller,
--- and hence inlinable.
--- (b) it can also save allocation when the function is recursive:
--- h = \x -> letrec f = \y -> ...f...y...x...
--- in f x
--- becomes
--- f = \x y -> ...(f x)...y...x...
--- h = \x -> f x x
--- No allocation for f now.
--- We may only want to do this if there are sufficiently few free
--- variables. We certainly only want to do it for values, and not for
--- constructors. So the simple thing is just to look for lambdas
-isFunction (_, AnnLam b e) | isId b = True
- | otherwise = isFunction e
-isFunction (_, AnnNote n e) = isFunction e
-isFunction other = False
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Free-To-Level Monad}
-%* *
-%************************************************************************
-
-\begin{code}
-type LevelEnv = (Bool, -- True <=> Float lambdas too
- VarEnv Level, -- Domain is *post-cloned* TyVars and Ids
- Subst, -- Domain is pre-cloned Ids; tracks the in-scope set
- -- so that subtitution is capture-avoiding
- IdEnv ([Var], LevelledExpr)) -- Domain is pre-cloned Ids
- -- We clone let-bound variables so that they are still
- -- distinct when floated out; hence the SubstEnv/IdEnv.
- -- (see point 3 of the module overview comment).
- -- We also use these envs when making a variable polymorphic
- -- because we want to float it out past a big lambda.
- --
- -- The SubstEnv and IdEnv always implement the same mapping, but the
- -- SubstEnv maps to CoreExpr and the IdEnv to LevelledExpr
- -- Since the range is always a variable or type application,
- -- there is never any difference between the two, but sadly
- -- the types differ. The SubstEnv is used when substituting in
- -- a variable's IdInfo; the IdEnv when we find a Var.
- --
- -- In addition the IdEnv records a list of tyvars free in the
- -- type application, just so we don't have to call freeVars on
- -- the type application repeatedly.
- --
- -- The domain of the both envs is *pre-cloned* Ids, though
- --
- -- The domain of the VarEnv Level is the *post-cloned* Ids
-
-initialEnv :: Bool -> LevelEnv
-initialEnv float_lams = (float_lams, emptyVarEnv, emptySubst, emptyVarEnv)
-
-floatLams :: LevelEnv -> Bool
-floatLams (float_lams, _, _, _) = float_lams
-
-extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
--- Used when *not* cloning
-extendLvlEnv (float_lams, lvl_env, subst, id_env) prs
- = (float_lams,
- foldl add_lvl lvl_env prs,
- foldl del_subst subst prs,
- foldl del_id id_env prs)
- where
- add_lvl env (v,l) = extendVarEnv env v l
- del_subst env (v,_) = extendInScope env v
- del_id env (v,_) = delVarEnv env v
- -- We must remove any clone for this variable name in case of
- -- shadowing. This bit me in the following case
- -- (in nofib/real/gg/Spark.hs):
- --
- -- case ds of wild {
- -- ... -> case e of wild {
- -- ... -> ... wild ...
- -- }
- -- }
- --
- -- The inside occurrence of @wild@ was being replaced with @ds@,
- -- incorrectly, because the SubstEnv was still lying around. Ouch!
- -- KSW 2000-07.
-
--- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can
--- (see point 4 of the module overview comment)
-extendCaseBndrLvlEnv env scrut case_bndr lvl
- = case scrut of
- Var v -> extendCloneLvlEnv lvl env [(case_bndr, v)]
- other -> extendLvlEnv env [(case_bndr,lvl)]
-
-extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pairs
- = (float_lams,
- foldl add_lvl lvl_env bndr_pairs,
- foldl add_subst subst bndr_pairs,
- foldl add_id id_env bndr_pairs)
- where
- add_lvl env (v,v') = extendVarEnv env v' dest_lvl
- add_subst env (v,v') = extendSubst env v (DoneEx (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, subst, id_env) bndr_pairs
- = (float_lams,
- foldl add_lvl lvl_env bndr_pairs,
- foldl add_subst subst bndr_pairs,
- foldl add_id id_env bndr_pairs)
- where
- add_lvl env (v,v') = extendVarEnv env v' lvl
- add_subst env (v,v') = extendSubst env v (DoneEx (Var v'))
- add_id env (v,v') = extendVarEnv env v ([v'], Var v')
-
-
-maxIdLevel :: LevelEnv -> VarSet -> Level
-maxIdLevel (_, lvl_env,_,id_env) var_set
- = foldVarSet max_in tOP_LEVEL var_set
- where
- max_in in_var lvl = foldr max_out lvl (case lookupVarEnv id_env in_var of
- Just (abs_vars, _) -> abs_vars
- Nothing -> [in_var])
-
- max_out out_var lvl
- | isId out_var = case lookupVarEnv lvl_env out_var of
- Just lvl' -> maxLvl lvl' lvl
- Nothing -> lvl
- | otherwise = lvl -- Ignore tyvars in *maxIdLevel*
-
-lookupVar :: LevelEnv -> Id -> LevelledExpr
-lookupVar (_, _, _, id_env) v = case lookupVarEnv id_env v of
- Just (_, expr) -> expr
- other -> Var v
-
-absVarsOf :: Level -> LevelEnv -> Var -> [Var]
- -- If f is free in the exression, and f maps to poly_f a b c in the
- -- current substitution, then we must report a b c as candidate type
- -- variables
-absVarsOf dest_lvl (_, lvl_env, _, id_env) v
- | isId v
- = [final_av | av <- lookup_avs v, abstract_me av, final_av <- add_tyvars av]
-
- | otherwise
- = if abstract_me v then [v] else []
-
- where
- abstract_me v = case lookupVarEnv lvl_env v of
- Just lvl -> dest_lvl `ltLvl` lvl
- Nothing -> False
-
- lookup_avs v = case lookupVarEnv id_env v of
- Just (abs_vars, _) -> abs_vars
- Nothing -> [v]
-
- -- We are going to lambda-abstract, so nuke any IdInfo,
- -- and add the tyvars of the Id
- add_tyvars v | isId v = zap v : varSetElems (idFreeTyVars v)
- | otherwise = [v]
-
- zap v = WARN( workerExists (idWorkerInfo v)
- || not (isEmptyCoreRules (idSpecialisation v)),
- text "absVarsOf: discarding info on" <+> ppr v )
- setIdInfo v vanillaIdInfo
-\end{code}
-
-\begin{code}
-type LvlM result = UniqSM result
-
-initLvl = initUs_
-thenLvl = thenUs
-returnLvl = returnUs
-mapLvl = mapUs
-\end{code}
-
-\begin{code}
-newPolyBndrs dest_lvl env abs_vars bndrs
- = getUniquesUs (length bndrs) `thenLvl` \ uniqs ->
- let
- new_bndrs = zipWith mk_poly_bndr bndrs uniqs
- in
- returnLvl (extendPolyLvlEnv dest_lvl env abs_vars (bndrs `zip` new_bndrs), new_bndrs)
- where
- mk_poly_bndr bndr uniq = mkSysLocal (_PK_ str) uniq poly_ty
- where
- str = "poly_" ++ occNameUserString (getOccName bndr)
- poly_ty = foldr mkPiType (idType bndr) abs_vars
-
-
-newLvlVar :: String
- -> [CoreBndr] -> Type -- Abstract wrt these bndrs
- -> LvlM Id
-newLvlVar str vars body_ty
- = getUniqueUs `thenLvl` \ uniq ->
- returnUs (mkSysLocal (_PK_ str) uniq (foldr mkPiType body_ty vars))
-
--- The deeply tiresome thing is that we have to apply the substitution
--- to the rules inside each Id. Grr. But it matters.
-
-cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id)
-cloneVar TopLevel env v ctxt_lvl dest_lvl
- = returnUs (env, v) -- Don't clone top level things
-cloneVar NotTopLevel env v ctxt_lvl dest_lvl
- = ASSERT( isId v )
- getUniqueUs `thenLvl` \ uniq ->
- let
- v' = setVarUnique v uniq
- v'' = subst_id_info env ctxt_lvl dest_lvl v'
- env' = extendCloneLvlEnv dest_lvl env [(v,v'')]
- in
- returnUs (env', v'')
-
-cloneVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id])
-cloneVars TopLevel env vs ctxt_lvl dest_lvl
- = returnUs (env, vs) -- Don't clone top level things
-cloneVars NotTopLevel env vs ctxt_lvl dest_lvl
- = ASSERT( all isId vs )
- getUniquesUs (length vs) `thenLvl` \ uniqs ->
- let
- vs' = zipWith setVarUnique vs uniqs
- vs'' = map (subst_id_info env' ctxt_lvl dest_lvl) vs'
- env' = extendCloneLvlEnv dest_lvl env (vs `zip` vs'')
- in
- returnUs (env', vs'')
-
-subst_id_info (_, _, subst, _) ctxt_lvl dest_lvl v
- = modifyIdInfo (\info -> substIdInfo subst info (zap_dmd info)) v
- where
- -- VERY IMPORTANT: we must zap the demand info
- -- if the thing is going to float out past a lambda
- zap_dmd info
- | stays_put || not (isStrict (demandInfo info)) = info
- | otherwise = setDemandInfo info wwLazy
-
- stays_put = ctxt_lvl == dest_lvl
-\end{code}
-
+%\r
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998\r
+%\r
+\section{SetLevels}\r
+\r
+ ***************************\r
+ Overview\r
+ ***************************\r
+\r
+1. We attach binding levels to Core bindings, in preparation for floating\r
+ outwards (@FloatOut@).\r
+\r
+2. We also let-ify many expressions (notably case scrutinees), so they\r
+ will have a fighting chance of being floated sensible.\r
+\r
+3. We clone the binders of any floatable let-binding, so that when it is\r
+ floated out it will be unique. (This used to be done by the simplifier\r
+ but the latter now only ensures that there's no shadowing; indeed, even \r
+ that may not be true.)\r
+\r
+ NOTE: this can't be done using the uniqAway idea, because the variable\r
+ must be unique in the whole program, not just its current scope,\r
+ because two variables in different scopes may float out to the\r
+ same top level place\r
+\r
+ NOTE: Very tiresomely, we must apply this substitution to\r
+ the rules stored inside a variable too.\r
+\r
+ We do *not* clone top-level bindings, because some of them must not change,\r
+ but we *do* clone bindings that are heading for the top level\r
+\r
+4. In the expression\r
+ case x of wild { p -> ...wild... }\r
+ we substitute x for wild in the RHS of the case alternatives:\r
+ case x of wild { p -> ...x... }\r
+ This means that a sub-expression involving x is not "trapped" inside the RHS.\r
+ And it's not inconvenient because we already have a substitution.\r
+\r
+ Note that this is EXACTLY BACKWARDS from the what the simplifier does.\r
+ The simplifier tries to get rid of occurrences of x, in favour of wild,\r
+ in the hope that there will only be one remaining occurrence of x, namely\r
+ the scrutinee of the case, and we can inline it. \r
+\r
+\begin{code}\r
+module SetLevels (\r
+ setLevels,\r
+\r
+ Level(..), tOP_LEVEL,\r
+\r
+ incMinorLvl, ltMajLvl, ltLvl, isTopLvl\r
+ ) where\r
+\r
+#include "HsVersions.h"\r
+\r
+import CoreSyn\r
+\r
+import CoreUtils ( exprType, exprIsTrivial, exprIsBottom, mkPiType )\r
+import CoreFVs -- all of it\r
+import Subst\r
+import Id ( Id, idType, mkSysLocal, isOneShotLambda, zapDemandIdInfo,\r
+ idSpecialisation, idWorkerInfo, setIdInfo\r
+ )\r
+import IdInfo ( workerExists, vanillaIdInfo, )\r
+import Var ( Var )\r
+import VarSet\r
+import VarEnv\r
+import Name ( getOccName )\r
+import OccName ( occNameUserString )\r
+import Type ( isUnLiftedType, Type )\r
+import BasicTypes ( TopLevelFlag(..) )\r
+import UniqSupply\r
+import Util ( sortLt, isSingleton, count )\r
+import Outputable\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{Level numbers}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+data Level = Level Int -- Level number of enclosing lambdas\r
+ Int -- Number of big-lambda and/or case expressions between\r
+ -- here and the nearest enclosing lambda\r
+\end{code}\r
+\r
+The {\em level number} on a (type-)lambda-bound variable is the\r
+nesting depth of the (type-)lambda which binds it. The outermost lambda\r
+has level 1, so (Level 0 0) means that the variable is bound outside any lambda.\r
+\r
+On an expression, it's the maximum level number of its free\r
+(type-)variables. On a let(rec)-bound variable, it's the level of its\r
+RHS. On a case-bound variable, it's the number of enclosing lambdas.\r
+\r
+Top-level variables: level~0. Those bound on the RHS of a top-level\r
+definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown\r
+as ``subscripts'')...\r
+\begin{verbatim}\r
+a_0 = let b_? = ... in\r
+ x_1 = ... b ... in ...\r
+\end{verbatim}\r
+\r
+The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).\r
+That's meant to be the level number of the enclosing binder in the\r
+final (floated) program. If the level number of a sub-expression is\r
+less than that of the context, then it might be worth let-binding the\r
+sub-expression so that it will indeed float. This context level starts\r
+at @Level 0 0@.\r
+\r
+\begin{code}\r
+type LevelledExpr = TaggedExpr Level\r
+type LevelledBind = TaggedBind Level\r
+\r
+tOP_LEVEL = Level 0 0\r
+\r
+incMajorLvl :: Level -> Level\r
+incMajorLvl (Level major minor) = Level (major+1) 0\r
+\r
+incMinorLvl :: Level -> Level\r
+incMinorLvl (Level major minor) = Level major (minor+1)\r
+\r
+maxLvl :: Level -> Level -> Level\r
+maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)\r
+ | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1\r
+ | otherwise = l2\r
+\r
+ltLvl :: Level -> Level -> Bool\r
+ltLvl (Level maj1 min1) (Level maj2 min2)\r
+ = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)\r
+\r
+ltMajLvl :: Level -> Level -> Bool\r
+ -- Tells if one level belongs to a difft *lambda* level to another\r
+ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2\r
+\r
+isTopLvl :: Level -> Bool\r
+isTopLvl (Level 0 0) = True\r
+isTopLvl other = False\r
+\r
+instance Outputable Level where\r
+ ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]\r
+\r
+instance Eq Level where\r
+ (Level maj1 min1) == (Level maj2 min2) = maj1==maj2 && min1==min2\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{Main level-setting code}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+setLevels :: Bool -- True <=> float lambdas to top level\r
+ -> [CoreBind]\r
+ -> UniqSupply\r
+ -> [LevelledBind]\r
+\r
+setLevels float_lams binds us\r
+ = initLvl us (do_them binds)\r
+ where\r
+ -- "do_them"'s main business is to thread the monad along\r
+ -- It gives each top binding the same empty envt, because\r
+ -- things unbound in the envt have level number zero implicitly\r
+ do_them :: [CoreBind] -> LvlM [LevelledBind]\r
+\r
+ do_them [] = returnLvl []\r
+ do_them (b:bs)\r
+ = lvlTopBind init_env b `thenLvl` \ (lvld_bind, _) ->\r
+ do_them bs `thenLvl` \ lvld_binds ->\r
+ returnLvl (lvld_bind : lvld_binds)\r
+\r
+ init_env = initialEnv float_lams\r
+\r
+lvlTopBind env (NonRec binder rhs)\r
+ = lvlBind TopLevel tOP_LEVEL env (AnnNonRec binder (freeVars rhs))\r
+ -- Rhs can have no free vars!\r
+\r
+lvlTopBind env (Rec pairs)\r
+ = lvlBind TopLevel tOP_LEVEL env (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{Setting expression levels}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+lvlExpr :: Level -- ctxt_lvl: Level of enclosing expression\r
+ -> LevelEnv -- Level of in-scope names/tyvars\r
+ -> CoreExprWithFVs -- input expression\r
+ -> LvlM LevelledExpr -- Result expression\r
+\end{code}\r
+\r
+The @ctxt_lvl@ is, roughly, the level of the innermost enclosing\r
+binder. Here's an example\r
+\r
+ v = \x -> ...\y -> let r = case (..x..) of\r
+ ..x..\r
+ in ..\r
+\r
+When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's\r
+the level of @r@, even though it's inside a level-2 @\y@. It's\r
+important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we\r
+don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE\r
+--- because it isn't a *maximal* free expression.\r
+\r
+If there were another lambda in @r@'s rhs, it would get level-2 as well.\r
+\r
+\begin{code}\r
+lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty)\r
+lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v)\r
+lvlExpr _ env (_, AnnLit lit) = returnLvl (Lit lit)\r
+\r
+lvlExpr ctxt_lvl env (_, AnnApp fun arg)\r
+ = lvl_fun fun `thenLvl` \ fun' ->\r
+ lvlMFE False ctxt_lvl env arg `thenLvl` \ arg' ->\r
+ returnLvl (App fun' arg')\r
+ where\r
+ lvl_fun (_, AnnCase _ _ _) = lvlMFE True ctxt_lvl env fun\r
+ lvl_fun other = lvlExpr ctxt_lvl env fun\r
+ -- We don't do MFE on partial applications generally,\r
+ -- but we do if the function is big and hairy, like a case\r
+\r
+lvlExpr ctxt_lvl env (_, AnnNote InlineMe expr)\r
+-- Don't float anything out of an InlineMe; hence the tOP_LEVEL\r
+ = lvlExpr tOP_LEVEL env expr `thenLvl` \ expr' ->\r
+ returnLvl (Note InlineMe expr')\r
+\r
+lvlExpr ctxt_lvl env (_, AnnNote note expr)\r
+ = lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->\r
+ returnLvl (Note note expr')\r
+\r
+-- We don't split adjacent lambdas. That is, given\r
+-- \x y -> (x+1,y)\r
+-- we don't float to give \r
+-- \x -> let v = x+y in \y -> (v,y)\r
+-- Why not? Because partial applications are fairly rare, and splitting\r
+-- lambdas makes them more expensive.\r
+\r
+lvlExpr ctxt_lvl env expr@(_, AnnLam bndr rhs)\r
+ = lvlMFE True new_lvl new_env body `thenLvl` \ new_body ->\r
+ returnLvl (glue_binders new_bndrs expr new_body)\r
+ where \r
+ (bndrs, body) = collect_binders expr\r
+ (new_lvl, new_bndrs) = lvlLamBndrs ctxt_lvl bndrs\r
+ new_env = extendLvlEnv env new_bndrs\r
+\r
+lvlExpr ctxt_lvl env (_, AnnLet bind body)\r
+ = lvlBind NotTopLevel ctxt_lvl env bind `thenLvl` \ (bind', new_env) ->\r
+ lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->\r
+ returnLvl (Let bind' body')\r
+\r
+lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)\r
+ = lvlMFE True ctxt_lvl env expr `thenLvl` \ expr' ->\r
+ let\r
+ alts_env = extendCaseBndrLvlEnv env expr' case_bndr incd_lvl\r
+ in\r
+ mapLvl (lvl_alt alts_env) alts `thenLvl` \ alts' ->\r
+ returnLvl (Case expr' (case_bndr, incd_lvl) alts')\r
+ where\r
+ incd_lvl = incMinorLvl ctxt_lvl\r
+\r
+ lvl_alt alts_env (con, bs, rhs)\r
+ = lvlMFE True incd_lvl new_env rhs `thenLvl` \ rhs' ->\r
+ returnLvl (con, bs', rhs')\r
+ where\r
+ bs' = [ (b, incd_lvl) | b <- bs ]\r
+ new_env = extendLvlEnv alts_env bs'\r
+\r
+collect_binders lam\r
+ = go [] lam\r
+ where\r
+ go rev_bndrs (_, AnnLam b e) = go (b:rev_bndrs) e\r
+ go rev_bndrs (_, AnnNote n e) = go rev_bndrs e\r
+ go rev_bndrs rhs = (reverse rev_bndrs, rhs)\r
+ -- Ignore notes, because we don't want to split\r
+ -- a lambda like this (\x -> coerce t (\s -> ...))\r
+ -- This happens quite a bit in state-transformer programs\r
+\r
+ -- glue_binders puts the lambda back together\r
+glue_binders (b:bs) (_, AnnLam _ e) body = Lam b (glue_binders bs e body)\r
+glue_binders bs (_, AnnNote n e) body = Note n (glue_binders bs e body)\r
+glue_binders [] e body = body\r
+\end{code}\r
+\r
+@lvlMFE@ is just like @lvlExpr@, except that it might let-bind\r
+the expression, so that it can itself be floated.\r
+\r
+\begin{code}\r
+lvlMFE :: Bool -- True <=> strict context [body of case or let]\r
+ -> Level -- Level of innermost enclosing lambda/tylam\r
+ -> LevelEnv -- Level of in-scope names/tyvars\r
+ -> CoreExprWithFVs -- input expression\r
+ -> LvlM LevelledExpr -- Result expression\r
+\r
+lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty)\r
+ = returnLvl (Type ty)\r
+\r
+lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)\r
+ | isUnLiftedType ty -- Can't let-bind it\r
+ || not good_destination\r
+ || exprIsTrivial expr -- Is trivial\r
+ || (strict_ctxt && exprIsBottom expr) -- Strict context and is bottom\r
+ -- e.g. \x -> error "foo"\r
+ -- No gain from floating this\r
+ = -- Don't float it out\r
+ lvlExpr ctxt_lvl env ann_expr\r
+\r
+ | otherwise -- Float it out!\r
+ = lvlFloatRhs abs_vars dest_lvl env ann_expr `thenLvl` \ expr' ->\r
+ newLvlVar "lvl" abs_vars ty `thenLvl` \ var ->\r
+ returnLvl (Let (NonRec (var,dest_lvl) expr') \r
+ (mkVarApps (Var var) abs_vars))\r
+ where\r
+ expr = deAnnotate ann_expr\r
+ ty = exprType expr\r
+ dest_lvl = destLevel env fvs (isFunction ann_expr)\r
+ abs_vars = abstractVars dest_lvl env fvs\r
+\r
+ good_destination = dest_lvl `ltMajLvl` ctxt_lvl -- Escapes a value lambda\r
+ || (isTopLvl dest_lvl && not strict_ctxt) -- Goes to the top\r
+ -- A decision to float entails let-binding this thing, and we only do \r
+ -- that if we'll escape a value lambda, or will go to the top level.\r
+ -- But beware\r
+ -- concat = /\ a -> foldr ..a.. (++) []\r
+ -- was getting turned into\r
+ -- concat = /\ a -> lvl a\r
+ -- lvl = /\ a -> foldr ..a.. (++) []\r
+ -- which is pretty stupid. Hence the strict_ctxt test\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{Bindings}\r
+%* *\r
+%************************************************************************\r
+\r
+The binding stuff works for top level too.\r
+\r
+\begin{code}\r
+lvlBind :: TopLevelFlag -- Used solely to decide whether to clone\r
+ -> Level -- Context level; might be Top even for bindings nested in the RHS\r
+ -- of a top level binding\r
+ -> LevelEnv\r
+ -> CoreBindWithFVs\r
+ -> LvlM (LevelledBind, LevelEnv)\r
+\r
+lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))\r
+ | null abs_vars\r
+ = -- No type abstraction; clone existing binder\r
+ lvlExpr dest_lvl env rhs `thenLvl` \ rhs' ->\r
+ cloneVar top_lvl env bndr ctxt_lvl dest_lvl `thenLvl` \ (env', bndr') ->\r
+ returnLvl (NonRec (bndr', dest_lvl) rhs', env') \r
+\r
+ | otherwise\r
+ = -- Yes, type abstraction; create a new binder, extend substitution, etc\r
+ lvlFloatRhs abs_vars dest_lvl env rhs `thenLvl` \ rhs' ->\r
+ newPolyBndrs dest_lvl env abs_vars [bndr] `thenLvl` \ (env', [bndr']) ->\r
+ returnLvl (NonRec (bndr', dest_lvl) rhs', env')\r
+\r
+ where\r
+ bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr\r
+ abs_vars = abstractVars dest_lvl env bind_fvs\r
+\r
+ dest_lvl | isUnLiftedType (idType bndr) = destLevel env bind_fvs False `maxLvl` Level 1 0\r
+ | otherwise = destLevel env bind_fvs (isFunction rhs)\r
+ -- Hack alert! We do have some unlifted bindings, for cheap primops, and \r
+ -- it is ok to float them out; but not to the top level. If they would otherwise\r
+ -- go to the top level, we pin them inside the topmost lambda\r
+\end{code}\r
+\r
+\r
+\begin{code}\r
+lvlBind top_lvl ctxt_lvl env (AnnRec pairs)\r
+ | null abs_vars\r
+ = cloneRecVars top_lvl env bndrs ctxt_lvl dest_lvl `thenLvl` \ (new_env, new_bndrs) ->\r
+ mapLvl (lvlExpr ctxt_lvl new_env) rhss `thenLvl` \ new_rhss ->\r
+ returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)\r
+\r
+ | isSingleton pairs && count isId abs_vars > 1\r
+ = -- Special case for self recursion where there are\r
+ -- several variables carried around: build a local loop: \r
+ -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars\r
+ -- This just makes the closures a bit smaller. If we don't do\r
+ -- this, allocation rises significantly on some programs\r
+ --\r
+ -- We could elaborate it for the case where there are several\r
+ -- mutually functions, but it's quite a bit more complicated\r
+ -- \r
+ -- This all seems a bit ad hoc -- sigh\r
+ let\r
+ (bndr,rhs) = head pairs\r
+ (rhs_lvl, abs_vars_w_lvls) = lvlLamBndrs dest_lvl abs_vars\r
+ rhs_env = extendLvlEnv env abs_vars_w_lvls\r
+ in\r
+ cloneVar NotTopLevel rhs_env bndr rhs_lvl rhs_lvl `thenLvl` \ (rhs_env', new_bndr) ->\r
+ let\r
+ (lam_bndrs, rhs_body) = collect_binders rhs\r
+ (body_lvl, new_lam_bndrs) = lvlLamBndrs rhs_lvl lam_bndrs\r
+ body_env = extendLvlEnv rhs_env' new_lam_bndrs\r
+ in\r
+ lvlExpr body_lvl body_env rhs_body `thenLvl` \ new_rhs_body ->\r
+ newPolyBndrs dest_lvl env abs_vars [bndr] `thenLvl` \ (poly_env, [poly_bndr]) ->\r
+ returnLvl (Rec [((poly_bndr,dest_lvl), mkLams abs_vars_w_lvls $\r
+ glue_binders new_lam_bndrs rhs $\r
+ Let (Rec [((new_bndr,rhs_lvl), mkLams new_lam_bndrs new_rhs_body)]) \r
+ (mkVarApps (Var new_bndr) lam_bndrs))],\r
+ poly_env)\r
+\r
+ | otherwise\r
+ = newPolyBndrs dest_lvl env abs_vars bndrs `thenLvl` \ (new_env, new_bndrs) ->\r
+ mapLvl (lvlFloatRhs abs_vars dest_lvl new_env) rhss `thenLvl` \ new_rhss ->\r
+ returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)\r
+\r
+ where\r
+ (bndrs,rhss) = unzip pairs\r
+\r
+ -- Finding the free vars of the binding group is annoying\r
+ bind_fvs = (unionVarSets [ idFreeVars bndr `unionVarSet` rhs_fvs\r
+ | (bndr, (rhs_fvs,_)) <- pairs])\r
+ `minusVarSet`\r
+ mkVarSet bndrs\r
+\r
+ dest_lvl = destLevel env bind_fvs (all isFunction rhss)\r
+ abs_vars = abstractVars dest_lvl env bind_fvs\r
+\r
+----------------------------------------------------\r
+-- Three help functons for the type-abstraction case\r
+\r
+lvlFloatRhs abs_vars dest_lvl env rhs\r
+ = lvlExpr rhs_lvl rhs_env rhs `thenLvl` \ rhs' ->\r
+ returnLvl (mkLams abs_vars_w_lvls rhs')\r
+ where\r
+ (rhs_lvl, abs_vars_w_lvls) = lvlLamBndrs dest_lvl abs_vars\r
+ rhs_env = extendLvlEnv env abs_vars_w_lvls\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{Deciding floatability}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [(CoreBndr, Level)])\r
+-- Compute the levels for the binders of a lambda group\r
+-- The binders returned are exactly the same as the ones passed,\r
+-- but they are now paired with a level\r
+lvlLamBndrs lvl [] \r
+ = (lvl, [])\r
+\r
+lvlLamBndrs lvl bndrs\r
+ = go (incMinorLvl lvl)\r
+ False -- Havn't bumped major level in this group\r
+ [] bndrs\r
+ where\r
+ go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs)\r
+ | isId bndr && -- Go to the next major level if this is a value binder,\r
+ not bumped_major && -- and we havn't already gone to the next level (one jump per group)\r
+ not (isOneShotLambda bndr) -- and it isn't a one-shot lambda\r
+ = go new_lvl True ((bndr,new_lvl) : rev_lvld_bndrs) bndrs\r
+\r
+ | otherwise\r
+ = go old_lvl bumped_major ((bndr,old_lvl) : rev_lvld_bndrs) bndrs\r
+\r
+ where\r
+ new_lvl = incMajorLvl old_lvl\r
+\r
+ go old_lvl _ rev_lvld_bndrs []\r
+ = (old_lvl, reverse rev_lvld_bndrs)\r
+ -- a lambda like this (\x -> coerce t (\s -> ...))\r
+ -- This happens quite a bit in state-transformer programs\r
+\end{code}\r
+\r
+\begin{code}\r
+abstractVars :: Level -> LevelEnv -> VarSet -> [Var]\r
+ -- Find the variables in fvs, free vars of the target expresion,\r
+ -- whose level is less than than the supplied level\r
+ -- These are the ones we are going to abstract out\r
+abstractVars dest_lvl env fvs\r
+ = uniq (sortLt lt [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])\r
+ where\r
+ -- Sort the variables so we don't get \r
+ -- mixed-up tyvars and Ids; it's just messy\r
+ v1 `lt` v2 = case (isId v1, isId v2) of\r
+ (True, False) -> False\r
+ (False, True) -> True\r
+ other -> v1 < v2 -- Same family\r
+ uniq :: [Var] -> [Var]\r
+ -- Remove adjacent duplicates; the sort will have brought them together\r
+ uniq (v1:v2:vs) | v1 == v2 = uniq (v2:vs)\r
+ | otherwise = v1 : uniq (v2:vs)\r
+ uniq vs = vs\r
+\r
+ -- Destintion level is the max Id level of the expression\r
+ -- (We'll abstract the type variables, if any.)\r
+destLevel :: LevelEnv -> VarSet -> Bool -> Level\r
+destLevel env fvs is_function\r
+ | floatLams env\r
+ && is_function = tOP_LEVEL -- Send functions to top level; see\r
+ -- the comments with isFunction\r
+ | otherwise = maxIdLevel env fvs\r
+\r
+isFunction :: CoreExprWithFVs -> Bool\r
+-- The idea here is that we want to float *functions* to\r
+-- the top level. This saves no work, but \r
+-- (a) it can make the host function body a lot smaller, \r
+-- and hence inlinable. \r
+-- (b) it can also save allocation when the function is recursive:\r
+-- h = \x -> letrec f = \y -> ...f...y...x...\r
+-- in f x\r
+-- becomes\r
+-- f = \x y -> ...(f x)...y...x...\r
+-- h = \x -> f x x\r
+-- No allocation for f now.\r
+-- We may only want to do this if there are sufficiently few free \r
+-- variables. We certainly only want to do it for values, and not for\r
+-- constructors. So the simple thing is just to look for lambdas\r
+isFunction (_, AnnLam b e) | isId b = True\r
+ | otherwise = isFunction e\r
+isFunction (_, AnnNote n e) = isFunction e\r
+isFunction other = False\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{Free-To-Level Monad}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+type LevelEnv = (Bool, -- True <=> Float lambdas too\r
+ VarEnv Level, -- Domain is *post-cloned* TyVars and Ids\r
+ Subst, -- Domain is pre-cloned Ids; tracks the in-scope set\r
+ -- so that subtitution is capture-avoiding\r
+ IdEnv ([Var], LevelledExpr)) -- Domain is pre-cloned Ids\r
+ -- We clone let-bound variables so that they are still\r
+ -- distinct when floated out; hence the SubstEnv/IdEnv.\r
+ -- (see point 3 of the module overview comment).\r
+ -- We also use these envs when making a variable polymorphic\r
+ -- because we want to float it out past a big lambda.\r
+ --\r
+ -- The SubstEnv and IdEnv always implement the same mapping, but the\r
+ -- SubstEnv maps to CoreExpr and the IdEnv to LevelledExpr\r
+ -- Since the range is always a variable or type application,\r
+ -- there is never any difference between the two, but sadly\r
+ -- the types differ. The SubstEnv is used when substituting in\r
+ -- a variable's IdInfo; the IdEnv when we find a Var.\r
+ --\r
+ -- In addition the IdEnv records a list of tyvars free in the\r
+ -- type application, just so we don't have to call freeVars on\r
+ -- the type application repeatedly.\r
+ --\r
+ -- The domain of the both envs is *pre-cloned* Ids, though\r
+ --\r
+ -- The domain of the VarEnv Level is the *post-cloned* Ids\r
+\r
+initialEnv :: Bool -> LevelEnv\r
+initialEnv float_lams = (float_lams, emptyVarEnv, emptySubst, emptyVarEnv)\r
+\r
+floatLams :: LevelEnv -> Bool\r
+floatLams (float_lams, _, _, _) = float_lams\r
+\r
+extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv\r
+-- Used when *not* cloning\r
+extendLvlEnv (float_lams, lvl_env, subst, id_env) prs\r
+ = (float_lams,\r
+ foldl add_lvl lvl_env prs,\r
+ foldl del_subst subst prs,\r
+ foldl del_id id_env prs)\r
+ where\r
+ add_lvl env (v,l) = extendVarEnv env v l\r
+ del_subst env (v,_) = extendInScope env v\r
+ del_id env (v,_) = delVarEnv env v\r
+ -- We must remove any clone for this variable name in case of\r
+ -- shadowing. This bit me in the following case\r
+ -- (in nofib/real/gg/Spark.hs):\r
+ -- \r
+ -- case ds of wild {\r
+ -- ... -> case e of wild {\r
+ -- ... -> ... wild ...\r
+ -- }\r
+ -- }\r
+ -- \r
+ -- The inside occurrence of @wild@ was being replaced with @ds@,\r
+ -- incorrectly, because the SubstEnv was still lying around. Ouch!\r
+ -- KSW 2000-07.\r
+\r
+-- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can\r
+-- (see point 4 of the module overview comment)\r
+extendCaseBndrLvlEnv (float_lams, lvl_env, subst, id_env) (Var scrut_var) case_bndr lvl\r
+ = (float_lams,\r
+ extendVarEnv lvl_env case_bndr lvl,\r
+ extendSubst subst case_bndr (DoneEx (Var scrut_var)),\r
+ extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var))\r
+ \r
+extendCaseBndrLvlEnv env scrut case_bndr lvl\r
+ = extendLvlEnv env [(case_bndr,lvl)]\r
+\r
+extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pairs\r
+ = (float_lams,\r
+ foldl add_lvl lvl_env bndr_pairs,\r
+ foldl add_subst subst bndr_pairs,\r
+ foldl add_id id_env bndr_pairs)\r
+ where\r
+ add_lvl env (v,v') = extendVarEnv env v' dest_lvl\r
+ add_subst env (v,v') = extendSubst env v (DoneEx (mkVarApps (Var v') abs_vars))\r
+ add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)\r
+\r
+extendCloneLvlEnv lvl (float_lams, lvl_env, _, id_env) new_subst bndr_pairs\r
+ = (float_lams,\r
+ foldl add_lvl lvl_env bndr_pairs,\r
+ new_subst,\r
+ foldl add_id id_env bndr_pairs)\r
+ where\r
+ add_lvl env (v,v') = extendVarEnv env v' lvl\r
+ add_id env (v,v') = extendVarEnv env v ([v'], Var v')\r
+\r
+\r
+maxIdLevel :: LevelEnv -> VarSet -> Level\r
+maxIdLevel (_, lvl_env,_,id_env) var_set\r
+ = foldVarSet max_in tOP_LEVEL var_set\r
+ where\r
+ max_in in_var lvl = foldr max_out lvl (case lookupVarEnv id_env in_var of\r
+ Just (abs_vars, _) -> abs_vars\r
+ Nothing -> [in_var])\r
+\r
+ max_out out_var lvl \r
+ | isId out_var = case lookupVarEnv lvl_env out_var of\r
+ Just lvl' -> maxLvl lvl' lvl\r
+ Nothing -> lvl \r
+ | otherwise = lvl -- Ignore tyvars in *maxIdLevel*\r
+\r
+lookupVar :: LevelEnv -> Id -> LevelledExpr\r
+lookupVar (_, _, _, id_env) v = case lookupVarEnv id_env v of\r
+ Just (_, expr) -> expr\r
+ other -> Var v\r
+\r
+absVarsOf :: Level -> LevelEnv -> Var -> [Var]\r
+ -- If f is free in the exression, and f maps to poly_f a b c in the\r
+ -- current substitution, then we must report a b c as candidate type\r
+ -- variables\r
+absVarsOf dest_lvl (_, lvl_env, _, id_env) v \r
+ | isId v\r
+ = [final_av | av <- lookup_avs v, abstract_me av, final_av <- add_tyvars av]\r
+\r
+ | otherwise\r
+ = if abstract_me v then [v] else []\r
+\r
+ where\r
+ abstract_me v = case lookupVarEnv lvl_env v of\r
+ Just lvl -> dest_lvl `ltLvl` lvl\r
+ Nothing -> False\r
+\r
+ lookup_avs v = case lookupVarEnv id_env v of\r
+ Just (abs_vars, _) -> abs_vars\r
+ Nothing -> [v]\r
+\r
+ -- We are going to lambda-abstract, so nuke any IdInfo,\r
+ -- and add the tyvars of the Id\r
+ add_tyvars v | isId v = zap v : varSetElems (idFreeTyVars v)\r
+ | otherwise = [v]\r
+\r
+ zap v = WARN( workerExists (idWorkerInfo v)\r
+ || not (isEmptyCoreRules (idSpecialisation v)),\r
+ text "absVarsOf: discarding info on" <+> ppr v )\r
+ setIdInfo v vanillaIdInfo\r
+\end{code}\r
+\r
+\begin{code}\r
+type LvlM result = UniqSM result\r
+\r
+initLvl = initUs_\r
+thenLvl = thenUs\r
+returnLvl = returnUs\r
+mapLvl = mapUs\r
+\end{code}\r
+\r
+\begin{code}\r
+newPolyBndrs dest_lvl env abs_vars bndrs\r
+ = getUniquesUs (length bndrs) `thenLvl` \ uniqs ->\r
+ let\r
+ new_bndrs = zipWith mk_poly_bndr bndrs uniqs\r
+ in\r
+ returnLvl (extendPolyLvlEnv dest_lvl env abs_vars (bndrs `zip` new_bndrs), new_bndrs)\r
+ where\r
+ mk_poly_bndr bndr uniq = mkSysLocal (_PK_ str) uniq poly_ty\r
+ where\r
+ str = "poly_" ++ occNameUserString (getOccName bndr)\r
+ poly_ty = foldr mkPiType (idType bndr) abs_vars\r
+ \r
+\r
+newLvlVar :: String \r
+ -> [CoreBndr] -> Type -- Abstract wrt these bndrs\r
+ -> LvlM Id\r
+newLvlVar str vars body_ty \r
+ = getUniqueUs `thenLvl` \ uniq ->\r
+ returnUs (mkSysLocal (_PK_ str) uniq (foldr mkPiType body_ty vars))\r
+ \r
+-- The deeply tiresome thing is that we have to apply the substitution\r
+-- to the rules inside each Id. Grr. But it matters.\r
+\r
+cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id)\r
+cloneVar TopLevel env v ctxt_lvl dest_lvl\r
+ = returnUs (env, v) -- Don't clone top level things\r
+cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl\r
+ = ASSERT( isId v )\r
+ getUs `thenLvl` \ us ->\r
+ let\r
+ (subst', v1) = substAndCloneId subst us v\r
+ v2 = zap_demand ctxt_lvl dest_lvl v1\r
+ env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)]\r
+ in\r
+ returnUs (env', v2)\r
+\r
+cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id])\r
+cloneRecVars TopLevel env vs ctxt_lvl dest_lvl \r
+ = returnUs (env, vs) -- Don't clone top level things\r
+cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl\r
+ = ASSERT( all isId vs )\r
+ getUs `thenLvl` \ us ->\r
+ let\r
+ (subst', vs1) = substAndCloneRecIds subst us vs\r
+ vs2 = map (zap_demand ctxt_lvl dest_lvl) vs1\r
+ env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2)\r
+ in\r
+ returnUs (env', vs2)\r
+\r
+ -- VERY IMPORTANT: we must zap the demand info \r
+ -- if the thing is going to float out past a lambda\r
+zap_demand dest_lvl ctxt_lvl id\r
+ | ctxt_lvl == dest_lvl = id -- Stays put\r
+ | otherwise = zapDemandIdInfo id -- Floats out\r
+\end{code}\r
+ \r
projects / ghc-hetmet.git / commitdiff