Overview
***************************
-* We attach binding levels to Core bindings, in preparation for floating
- outwards (@FloatOut@).
+1. We attach binding levels to Core bindings, in preparation for floating
+ outwards (@FloatOut@).
-* We also let-ify many expressions (notably case scrutinees), so they
- will have a fighting chance of being floated sensible.
+2. We also let-ify many expressions (notably case scrutinees), so they
+ will have a fighting chance of being floated sensible.
-* 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.)
- NOTE: Very tiresomely, we must apply this substitution to
- the rules stored inside a variable too.
+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.)
- 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
+ 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
-* In the expression
+ 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:
+ 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.
+ 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 (
import CoreSyn
-import CoreUtils ( exprType, exprIsTrivial, exprIsBottom )
+import CoreUtils ( exprType, exprIsTrivial, exprIsBottom, mkPiType )
import CoreFVs -- all of it
-import Id ( Id, idType, idFreeTyVars, mkSysLocal, isOneShotLambda, modifyIdInfo,
+import Subst
+import Id ( Id, idType, mkSysLocal, isOneShotLambda, modifyIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo
)
-import IdInfo ( workerExists, vanillaIdInfo )
-import Var ( Var, TyVar, setVarUnique )
-import VarEnv
-import Subst
+import IdInfo ( workerExists, vanillaIdInfo, demandInfo, setDemandInfo )
+import Var ( Var, setVarUnique )
import VarSet
+import VarEnv
import Name ( getOccName )
import OccName ( occNameUserString )
-import Type ( isUnLiftedType, mkPiType, Type )
+import Type ( isUnLiftedType, Type )
import BasicTypes ( TopLevelFlag(..) )
-import VarSet
-import VarEnv
+import Demand ( isStrict, wwLazy )
import UniqSupply
import Util ( sortLt, isSingleton, count )
import Outputable
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}
%************************************************************************
lvlExpr _ env (_, AnnLit lit) = returnLvl (Lit lit)
lvlExpr ctxt_lvl env (_, AnnApp fun arg)
- = lvlExpr ctxt_lvl env fun `thenLvl` \ fun' ->
+ = 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
- = lvlExpr tOP_LEVEL env expr `thenLvl` \ 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)
mapLvl (lvl_alt alts_env) alts `thenLvl` \ alts' ->
returnLvl (Case expr' (case_bndr, incd_lvl) alts')
where
- expr_type = exprType (deAnnotate expr)
incd_lvl = incMinorLvl ctxt_lvl
lvl_alt alts_env (con, bs, rhs)
lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
| isUnLiftedType ty -- Can't let-bind it
- || not (dest_lvl `ltMajLvl` ctxt_lvl) -- Does not escape a value lambda
- -- A decision to float entails let-binding this thing, and we only do
- -- that if we'll escape a value lambda. I considered doing it if it
- -- would make the thing go to top level, but I found things like
- -- concat = /\ a -> foldr ..a.. (++) []
- -- was getting turned into
- -- concat = /\ a -> lvl a
- -- lvl = /\ a -> foldr ..a.. (++) []
- -- which is pretty stupid. So for now at least, I don't let-bind things
- -- simply because they could go to top level.
+ || 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
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}
lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
| null abs_vars
= -- No type abstraction; clone existing binder
- lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' ->
- cloneVar top_lvl env bndr dest_lvl `thenLvl` \ (env', bndr') ->
+ 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
\begin{code}
lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
| null abs_vars
- = cloneVars top_lvl env bndrs dest_lvl `thenLvl` \ (new_env, new_bndrs) ->
- mapLvl (lvlExpr ctxt_lvl new_env) rhss `thenLvl` \ new_rhss ->
+ = 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
(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 `thenLvl` \ (rhs_env', new_bndr) ->
+ 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
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 ->
+ = 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
\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, [])
\begin{code}
type LevelEnv = (Bool, -- True <=> Float lambdas too
VarEnv Level, -- Domain is *post-cloned* TyVars and Ids
- SubstEnv, -- Domain is pre-cloned 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 two Envs always implement the same mapping, but the
+ -- 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 domain of the VarEnv Level is the *post-cloned* Ids
initialEnv :: Bool -> LevelEnv
-initialEnv float_lams = (float_lams, emptyVarEnv, emptySubstEnv, emptyVarEnv)
+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_env, id_env) prs
- = (float_lams, foldl add lvl_env prs, subst_env, id_env)
+-- 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 env (v,l) = extendVarEnv env v l
+ 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_env, id_env) abs_vars bndr_pairs
+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_env bndr_pairs,
- foldl add_id id_env bndr_pairs)
+ 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') = extendSubstEnv env v (DoneEx (mkVarApps (Var v') abs_vars))
- add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
+ 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_env, id_env) bndr_pairs
+extendCloneLvlEnv lvl (float_lams, lvl_env, subst, id_env) bndr_pairs
= (float_lams,
- foldl add_lvl lvl_env bndr_pairs,
- foldl add_subst subst_env bndr_pairs,
- foldl add_id id_env bndr_pairs)
+ 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') = extendSubstEnv env v (DoneEx (Var v'))
- add_id env (v,v') = extendVarEnv env v ([v'], Var v')
+ 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
-- 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 -> LvlM (LevelEnv, Id)
-cloneVar TopLevel env v lvl
+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 lvl
- = getUniqueUs `thenLvl` \ uniq ->
+cloneVar NotTopLevel env v ctxt_lvl dest_lvl
+ = ASSERT( isId v )
+ getUniqueUs `thenLvl` \ uniq ->
let
v' = setVarUnique v uniq
- v'' = subst_id_info env v'
- env' = extendCloneLvlEnv lvl env [(v,v'')]
+ 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 -> LvlM (LevelEnv, [Id])
-cloneVars TopLevel env vs lvl
+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 lvl
- = getUniquesUs (length vs) `thenLvl` \ uniqs ->
+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') vs'
- env' = extendCloneLvlEnv lvl env (vs `zip` vs'')
+ 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_env, _) v
- = modifyIdInfo (\info -> substIdInfo subst info info) v
+subst_id_info (_, _, subst, _) ctxt_lvl dest_lvl v
+ = modifyIdInfo (\info -> substIdInfo subst info (zap_dmd info)) v
where
- subst = mkSubst emptyVarSet subst_env
+ -- 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}
projects / ghc-hetmet.git / blobdiff