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.)
+ 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.
import CoreUtils ( exprType, exprIsTrivial, exprIsBottom, mkPiType )
import CoreFVs -- all of it
import Subst
-import Id ( Id, idType, idFreeTyVars, mkSysLocal, isOneShotLambda, modifyIdInfo,
+import Id ( Id, idType, mkSysLocal, isOneShotLambda, modifyIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo
)
import IdInfo ( workerExists, vanillaIdInfo, demandInfo, setDemandInfo )
\begin{code}
type LevelledExpr = TaggedExpr Level
-type LevelledArg = TaggedArg Level
type LevelledBind = TaggedBind Level
tOP_LEVEL = Level 0 0
ltMajLvl :: Level -> Level -> Bool
-- Tells if one level belongs to a difft *lambda* level to another
- -- But it returns True regardless if l1 is the top level
- -- We always like to float to the top!
-ltMajLvl (Level 0 0) _ = True
ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
isTopLvl :: Level -> Bool
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}
%************************************************************************
-- 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)
|| 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
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' ->
+ 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')
\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.
-- 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
+extendLvlEnv (float_lams, lvl_env, subst, id_env) prs
= (float_lams,
foldl add_lvl lvl_env prs,
- foldl del_subst subst_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,_) = delSubstEnv env v
+ 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):
+ -- shadowing. This bit me in the following case
+ -- (in nofib/real/gg/Spark.hs):
--
-- case ds of wild {
-- ... -> case e of wild {
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
in
returnUs (env', vs'')
-subst_id_info (_, _, subst_env, _) ctxt_lvl dest_lvl 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
- | float_past_lam && isStrict (demandInfo info)
- = setDemandInfo info wwLazy
- | otherwise
- = info
+ | stays_put || not (isStrict (demandInfo info)) = info
+ | otherwise = setDemandInfo info wwLazy
- float_past_lam = ctxt_lvl `ltMajLvl` dest_lvl
+ stays_put = ctxt_lvl == dest_lvl
\end{code}
projects / ghc-hetmet.git / blobdiff