* 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.
+
+ 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
import CoreUtils ( coreExprType, exprIsTrivial, exprIsBottom )
import CoreFVs -- all of it
-import Id ( Id, idType, mkSysLocal )
+import Id ( Id, idType, mkSysLocal, isOneShotLambda, modifyIdInfo )
+import IdInfo ( specInfo, setSpecInfo )
import Var ( IdOrTyVar, Var, setVarUnique )
import VarEnv
+import Subst
import VarSet
import Type ( isUnLiftedType, mkTyVarTys, mkForAllTys, Type )
+import BasicTypes ( TopLevelFlag(..) )
import VarSet
import VarEnv
import UniqSupply
ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
\end{code}
-\begin{code}
-type LevelEnv = VarEnv (Var, Level)
- -- We clone let-bound variables so that they are still
- -- distinct when floated out; hence the Var in the range
-
-extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
- -- Used when *not* cloning
-extendLvlEnv env prs = foldl add env prs
- where
- add env (v,l) = extendVarEnv env v (v,l)
-
-varLevel :: LevelEnv -> IdOrTyVar -> Level
-varLevel env v
- = case lookupVarEnv env v of
- Just (_,level) -> level
- Nothing -> tOP_LEVEL
-
-maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
-maxIdLvl env var lvl | isTyVar var = lvl
- | otherwise = case lookupVarEnv env var of
- Just (_,lvl') -> maxLvl lvl' lvl
- Nothing -> lvl
-
-maxTyVarLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
-maxTyVarLvl env var lvl | isId var = lvl
- | otherwise = case lookupVarEnv env var of
- Just (_,lvl') -> maxLvl lvl' lvl
- Nothing -> lvl
-\end{code}
-
%************************************************************************
%* *
\subsection{Main level-setting code}
do_them bs `thenLvl` \ lvld_binds ->
returnLvl (lvld_bind ++ lvld_binds)
-initialEnv = emptyVarEnv
-
lvlTopBind (NonRec binder rhs)
- = lvlBind Top initialEnv (AnnNonRec binder (freeVars rhs))
+ = lvlBind TopLevel Top initialEnv (AnnNonRec binder (freeVars rhs))
-- Rhs can have no free vars!
lvlTopBind (Rec pairs)
- = lvlBind Top initialEnv (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
+ = lvlBind TopLevel Top initialEnv (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
\end{code}
%************************************************************************
The binding stuff works for top level too.
\begin{code}
-lvlBind :: Level
+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 ctxt_lvl env (AnnNonRec bndr rhs)
+lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs)
= setFloatLevel (Just bndr) ctxt_lvl env rhs ty `thenLvl` \ (final_lvl, rhs') ->
- cloneVar ctxt_lvl bndr `thenLvl` \ new_bndr ->
- let
- new_env = extendVarEnv env bndr (new_bndr,final_lvl)
- in
+ cloneVar top_lvl env bndr final_lvl `thenLvl` \ (new_env, new_bndr) ->
returnLvl ([NonRec (new_bndr, final_lvl) rhs'], new_env)
where
ty = idType bndr
-lvlBind ctxt_lvl env (AnnRec pairs) = lvlRecBind ctxt_lvl env pairs
+lvlBind top_lvl ctxt_lvl env (AnnRec pairs) = lvlRecBind top_lvl ctxt_lvl env pairs
\end{code}
%************************************************************************
\begin{code}
lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty)
-lvlExpr _ env (_, AnnVar v) = case lookupVarEnv env v of
- Just (v',_) -> returnLvl (Var v')
- Nothing -> returnLvl (Var v)
+lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v)
lvlExpr ctxt_lvl env (_, AnnCon con args)
= mapLvl (lvlExpr ctxt_lvl env) args `thenLvl` \ args' ->
= lvlMFE incd_lvl new_env body `thenLvl` \ body' ->
returnLvl (mkLams lvld_bndrs body')
where
- bndr_is_id = isId bndr
- bndr_is_tyvar = isTyVar bndr
- (bndrs, body) = go rhs
+ bndr_is_id = isId bndr
+ bndr_is_tyvar = isTyVar bndr
+ (more_bndrs, body) = go rhs
+ bndrs = bndr : more_bndrs
+
+ incd_lvl | bndr_is_id && not (all isOneShotLambda bndrs) = incMajorLvl ctxt_lvl
+ | otherwise = incMinorLvl ctxt_lvl
+ -- Only bump the major level number if the binders include
+ -- at least one more-than-one-shot lambda
- incd_lvl | bndr_is_id = incMajorLvl ctxt_lvl
- | otherwise = incMinorLvl ctxt_lvl
- lvld_bndrs = [(b,incd_lvl) | b <- (bndr:bndrs)]
+ lvld_bndrs = [(b,incd_lvl) | b <- bndrs]
new_env = extendLvlEnv env lvld_bndrs
go (_, AnnLam bndr rhs) | bndr_is_id && isId bndr
go body = ([], body)
lvlExpr ctxt_lvl env (_, AnnLet bind body)
- = lvlBind ctxt_lvl env bind `thenLvl` \ (binds', new_env) ->
- lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
+ = lvlBind NotTopLevel ctxt_lvl env bind `thenLvl` \ (binds', new_env) ->
+ lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
returnLvl (mkLets binds' body')
lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
where
expr_type = coreExprType (deAnnotate expr)
incd_lvl = incMinorLvl ctxt_lvl
- alts_env = extendVarEnv env case_bndr (case_bndr,incd_lvl)
+ alts_env = extendLvlEnv env [(case_bndr,incd_lvl)]
lvl_alt (con, bs, rhs)
= let
type lambdas.
\begin{code}
-lvlRecBind ctxt_lvl env pairs
+lvlRecBind top_lvl ctxt_lvl env pairs
| ids_only_lvl `ltLvl` tyvars_only_lvl
= -- Abstract wrt tyvars;
-- offending_tyvars is definitely non-empty
in
mapLvl (lvlExpr incd_lvl rhs_env) rhss `thenLvl` \ rhss' ->
mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars ->
- mapLvl (cloneVar ctxt_lvl) bndrs `thenLvl` \ new_bndrs ->
+ cloneVars top_lvl env bndrs ctxt_lvl `thenLvl` \ (new_env, new_bndrs) ->
let
-- The "d_rhss" are the right-hand sides of "D" and "D'"
-- in the documentation above
-- The new right-hand sides, just a type application,
-- aren't worth floating so pin it with ctxt_lvl
bndrs_w_lvl = new_bndrs `zip` repeat ctxt_lvl
- new_env = extendVarEnvList env (bndrs `zip` bndrs_w_lvl)
-- "d_binds" are the "D" in the documentation above
d_binds = zipWithEqual "SetLevels" NonRec bndrs_w_lvl d_rhss
| otherwise
= -- Let it float freely
- mapLvl (cloneVar ctxt_lvl) bndrs `thenLvl` \ new_bndrs ->
+ cloneVars top_lvl env bndrs expr_lvl `thenLvl` \ (new_env, new_bndrs) ->
let
bndrs_w_lvls = new_bndrs `zip` repeat expr_lvl
- new_env = extendVarEnvList env (bndrs `zip` bndrs_w_lvls)
in
mapLvl (lvlExpr expr_lvl new_env) rhss `thenLvl` \ rhss' ->
returnLvl ([Rec (bndrs_w_lvls `zip` rhss')], new_env)
%************************************************************************
\begin{code}
+type LevelEnv = (VarEnv Level, SubstEnv)
+ -- We clone let-bound variables so that they are still
+ -- distinct when floated out; hence the SubstEnv
+ -- The domain of the VarEnv is *pre-cloned* Ids, though
+
+initialEnv :: LevelEnv
+initialEnv = (emptyVarEnv, emptySubstEnv)
+
+extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
+ -- Used when *not* cloning
+extendLvlEnv (lvl_env, subst_env) prs
+ = (foldl add lvl_env prs, subst_env)
+ where
+ add env (v,l) = extendVarEnv env v l
+
+varLevel :: LevelEnv -> IdOrTyVar -> Level
+varLevel (lvl_env, _) v
+ = case lookupVarEnv lvl_env v of
+ Just level -> level
+ Nothing -> tOP_LEVEL
+
+lookupVar :: LevelEnv -> Id -> LevelledExpr
+lookupVar (_, subst) v = case lookupSubstEnv subst v of
+ Just (DoneEx (Var v')) -> Var v' -- Urgh! Types don't match
+ other -> Var v
+
+maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
+maxIdLvl (lvl_env,_) var lvl | isTyVar var = lvl
+ | otherwise = case lookupVarEnv lvl_env var of
+ Just lvl' -> maxLvl lvl' lvl
+ Nothing -> lvl
+
+maxTyVarLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
+maxTyVarLvl (lvl_env,_) var lvl | isId var = lvl
+ | otherwise = case lookupVarEnv lvl_env var of
+ Just lvl' -> maxLvl lvl' lvl
+ Nothing -> lvl
+\end{code}
+
+\begin{code}
type LvlM result = UniqSM result
initLvl = initUs_
newLvlVar ty = getUniqueUs `thenLvl` \ uniq ->
returnUs (mkSysLocal SLIT("lvl") uniq ty)
-cloneVar :: Level -> Id -> LvlM Id
-cloneVar Top v = returnUs v -- Don't clone top level things
-cloneVar _ v = getUniqueUs `thenLvl` \ uniq ->
- returnUs (setVarUnique v uniq)
+-- 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
+ = returnUs (env, v) -- Don't clone top level things
+cloneVar NotTopLevel (lvl_env, subst_env) v lvl
+ = getUniqueUs `thenLvl` \ uniq ->
+ let
+ subst = mkSubst emptyVarSet subst_env
+ v' = setVarUnique v uniq
+ v'' = modifyIdInfo (\info -> substIdInfo subst info info) v'
+ subst_env' = extendSubstEnv subst_env v (DoneEx (Var v''))
+ lvl_env' = extendVarEnv lvl_env v lvl
+ in
+ returnUs ((lvl_env', subst_env'), v'')
+
+cloneVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> LvlM (LevelEnv, [Id])
+cloneVars TopLevel env vs lvl
+ = returnUs (env, vs) -- Don't clone top level things
+cloneVars NotTopLevel (lvl_env, subst_env) vs lvl
+ = getUniquesUs (length vs) `thenLvl` \ uniqs ->
+ let
+ subst = mkSubst emptyVarSet subst_env'
+ vs' = zipWith setVarUnique vs uniqs
+ vs'' = map (modifyIdInfo (\info -> substIdInfo subst info info)) vs'
+ subst_env' = extendSubstEnvList subst_env vs [DoneEx (Var v'') | v'' <- vs'']
+ lvl_env' = extendVarEnvList lvl_env (vs `zip` repeat lvl)
+ in
+ returnUs ((lvl_env', subst_env'), vs'')
\end{code}
projects / ghc-hetmet.git / blobdiff