will have a fighting chance of being floated sensible.
\begin{code}
-#include "HsVersions.h"
-
module SetLevels (
setLevels,
Level(..), tOP_LEVEL,
incMinorLvl, ltMajLvl, ltLvl, isTopLvl
--- not exported: , incMajorLvl, isTopMajLvl, unTopify
) where
-import Ubiq{-uitous-}
+#include "HsVersions.h"
import AnnCoreSyn
import CoreSyn
-import CoreUtils ( coreExprType, manifestlyWHNF, manifestlyBottom )
+import CoreUtils ( coreExprType, idSpecVars )
+import CoreUnfold ( FormSummary, whnfOrBottom, mkFormSummary )
import FreeVars -- all of it
-import Id ( idType, mkSysLocal, toplevelishId,
+import MkId ( mkSysLocal )
+import Id ( idType,
nullIdEnv, addOneToIdEnv, growIdEnvList,
- unionManyIdSets, minusIdSet, mkIdSet,
- idSetToList,
- lookupIdEnv, IdEnv(..)
+ unionManyIdSets, unionIdSets, minusIdSet, mkIdSet,
+ idSetToList, Id,
+ lookupIdEnv, IdEnv
)
-import Pretty ( ppStr, ppBesides, ppChar, ppInt )
-import SrcLoc ( mkUnknownSrcLoc )
-import Type ( isPrimType, mkTyVarTys, mkForAllTys )
-import TyVar ( nullTyVarEnv, addOneToTyVarEnv,
+import SrcLoc ( noSrcLoc )
+import Type ( isUnpointedType, mkTyVarTys, mkForAllTys, tyVarsOfTypes, Type )
+import TyVar ( emptyTyVarEnv, addToTyVarEnv,
growTyVarEnvList, lookupTyVarEnv,
- tyVarSetToList,
- TyVarEnv(..),
- unionManyTyVarSets
+ tyVarSetToList,
+ TyVarEnv, TyVar,
+ unionManyTyVarSets, unionTyVarSets
)
import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs,
- mapAndUnzip3Us, getUnique, UniqSM(..)
+ mapAndUnzip3Us, getUnique, UniqSM,
+ UniqSupply
)
-import Usage ( UVar(..) )
-import Util ( mapAccumL, zipWithEqual, panic, assertPanic )
+import BasicTypes ( Unused )
+import Util ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic )
+import Outputable
isLeakFreeType x y = False -- safe option; ToDo
\end{code}
at @Level 0 0@; it is never @Top@.
\begin{code}
-type LevelledExpr = GenCoreExpr (Id, Level) Id TyVar UVar
-type LevelledArg = GenCoreArg Id TyVar UVar
-type LevelledBind = GenCoreBinding (Id, Level) Id TyVar UVar
+type LevelledExpr = GenCoreExpr (Id, Level) Id Unused
+type LevelledArg = GenCoreArg Id Unused
+type LevelledBind = GenCoreBinding (Id, Level) Id Unused
type LevelEnvs = (IdEnv Level, -- bind Ids to levels
TyVarEnv Level) -- bind type variables to levels
unTopify lvl = lvl
instance Outputable Level where
- ppr sty Top = ppStr "<Top>"
- ppr sty (Level maj min) = ppBesides [ ppChar '<', ppInt maj, ppChar ',', ppInt min, ppChar '>' ]
+ ppr Top = ptext SLIT("<Top>")
+ ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
\end{code}
%************************************************************************
do_them bs `thenLvl` \ lvld_binds ->
returnLvl (lvld_bind ++ lvld_binds)
-initial_envs = (nullIdEnv, nullTyVarEnv)
+initial_envs = (nullIdEnv, emptyTyVarEnv)
lvlTopBind (NonRec binder rhs)
= lvlBind (Level 0 0) initial_envs (AnnNonRec binder (freeVars rhs))
The binding stuff works for top level too.
\begin{code}
-type CoreBindingWithFVs = AnnCoreBinding Id Id TyVar UVar FVInfo
+type CoreBindingWithFVs = AnnCoreBinding Id Id Unused FVInfo
lvlBind :: Level
-> LevelEnvs
binders_w_lvls = binders `zip` repeat final_lvl
new_envs = (growIdEnvList venv binders_w_lvls, tenv)
in
- returnLvl (extra_binds ++ [Rec (binders_w_lvls `zip` rhss')], new_envs)
+ returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_envs)
where
(binders,rhss) = unzip pairs
\end{code}
= lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' ->
returnLvl (App fun' arg)
-lvlExpr ctxt_lvl envs (_, AnnSCC cc expr)
+lvlExpr ctxt_lvl envs (_, AnnNote note expr)
= lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
- returnLvl (SCC cc 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 envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
- = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
- returnLvl (Lam (ValBinder (arg,incd_lvl)) rhs')
+ = lvlMFE incd_lvl (new_venv, tenv) body `thenLvl` \ body' ->
+ returnLvl (foldr (Lam . ValBinder) body' lvld_args)
where
- incd_lvl = incMajorLvl ctxt_lvl
- new_venv = growIdEnvList venv [(arg,incd_lvl)]
+ incd_lvl = incMajorLvl ctxt_lvl
+ (args, body) = annCollectValBinders rhs
+ lvld_args = [(a,incd_lvl) | a <- (arg:args)]
+ new_venv = growIdEnvList venv lvld_args
-lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) e)
- = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' ->
- returnLvl (Lam (TyBinder tyvar) e')
- where
- incd_lvl = incMinorLvl ctxt_lvl
- new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
+-- We don't need to play such tricks for type lambdas, because
+-- they don't get annotated
-lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (UsageBinder u) e)
- = panic "SetLevels.lvlExpr:AnnLam UsageBinder"
+lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) body)
+ = lvlExpr incd_lvl (venv, new_tenv) body `thenLvl` \ body' ->
+ returnLvl (Lam (TyBinder tyvar) body')
+ where
+ incd_lvl = incMinorLvl ctxt_lvl
+ new_tenv = addToTyVarEnv tenv tyvar incd_lvl
lvlExpr ctxt_lvl envs (_, AnnLet bind body)
= lvlBind ctxt_lvl envs bind `thenLvl` \ (binds', new_envs) ->
-> LvlM LevelledExpr -- Result expression
lvlMFE ctxt_lvl envs@(venv,_) ann_expr
- | isPrimType ty -- Can't let-bind it
+ | isUnpointedType ty -- Can't let-bind it
= lvlExpr ctxt_lvl envs ann_expr
| otherwise -- Not primitive type so could be let-bound
-- any harm, and not floating it may pin something important. For
-- example
--
--- x = let v = Nil
+-- x = let v = []
-- w = 1:v
-- in ...
--
offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
- manifestly_whnf = manifestlyWHNF de_ann_expr || manifestlyBottom de_ann_expr
+ manifestly_whnf = whnfOrBottom (mkFormSummary de_ann_expr)
maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
maybe_unTopify lvl = lvl
\begin{code}
decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
| isTopMajLvl ids_only_lvl && -- Destination = top
- not (all canFloatToTop (tys `zip` rhss)) -- Some can't float to top
+ not (all canFloatToTop (zipEqual "decideRec" tys rhss)) -- Some can't float to top
= -- Pin it here
let
ids_w_lvls = ids `zip` repeat ctxt_lvl
- new_envs = (growIdEnvList venv ids_w_lvls, tenv)
+ new_envs = (growIdEnvList venv ids_w_lvls, tenv)
in
mapLvl (lvlExpr ctxt_lvl new_envs) rhss `thenLvl` \ rhss' ->
returnLvl (ctxt_lvl, [], rhss')
mapLvl (lvlExpr incd_lvl new_envs) rhss `thenLvl` \ rhss' ->
mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars ->
let
- ids_w_poly_vars = ids `zip` poly_vars
+ ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars
-- The "d_rhss" are the right-hand sides of "D" and "D'"
-- in the documentation above
d_rhss = [ mkTyApp (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
-- "local_binds" are "D'" in the documentation above
- local_binds = zipWithEqual NonRec ids_w_incd_lvl d_rhss
+ local_binds = zipWithEqual "SetLevels" NonRec ids_w_incd_lvl d_rhss
poly_var_rhss = [ mkTyLam offending_tyvars (foldr Let rhs' local_binds)
| rhs' <- rhss' -- mkCoLet* requires Core...
]
- poly_binds = [(poly_var, ids_only_lvl) | poly_var <- poly_vars] `zip` poly_var_rhss
+ poly_binds = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars]
+ poly_var_rhss
in
returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
where
tys = map idType ids
- fvs = unionManyIdSets [freeVarsOf rhs | rhs <- rhss] `minusIdSet` mkIdSet ids
+ fvs = (unionManyIdSets [freeVarsOf rhs | rhs <- rhss] `unionIdSets`
+ mkIdSet (concat (map idSpecVars ids)))
+ `minusIdSet` mkIdSet ids
tfvs = unionManyTyVarSets [freeTyVarsOf rhs | rhs <- rhss]
+ `unionTyVarSets`
+ tyVarsOfTypes tys
+ -- Why the "tyVarsOfTypes" part? Consider this:
+ -- /\a -> letrec x::a = x in E
+ -- Now, there are no explicit free type variables in the RHS of x,
+ -- but nevertheless "a" is free in its definition. So we add in
+ -- the free tyvars of the types of the binders.
+ -- This actually happened in the defn of errorIO in IOBase.lhs:
+ -- errorIO (ST io) = case (errorIO# io) of
+ -- _ -> bottom
+ -- where
+ -- bottom = bottom -- Never evaluated
+ -- I don't think this can every happen for non-recursive bindings.
+
fv_list = idSetToList fvs
tv_list = tyVarSetToList tfvs
| otherwise = -- No point in adding a fresh let-binding for a WHNF, because
-- floating it isn't beneficial enough.
isWorthFloatingExpr expr &&
- not (manifestlyWHNF expr || manifestlyBottom expr)
+ not (whnfOrBottom expr)
********** -}
isWorthFloatingExpr :: CoreExpr -> Bool
canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
canFloatToTop (ty, (FVInfo _ _ MightLeak, expr)) = isLeakFreeType [] ty
-valSuggestsLeakFree expr = manifestlyWHNF expr || manifestlyBottom expr
+valSuggestsLeakFree expr = whnfOrBottom expr
\end{code}
idLevel venv v
= case lookupIdEnv venv v of
Just level -> level
- Nothing -> ASSERT(toplevelishId v)
- tOP_LEVEL
+ Nothing -> tOP_LEVEL
tyvarLevel :: TyVarEnv Level -> TyVar -> Level
tyvarLevel tenv tyvar
Nothing -> tOP_LEVEL
\end{code}
+\begin{code}
+annCollectValBinders (_, (AnnLam (ValBinder arg) rhs))
+ = (arg:args, body)
+ where
+ (args, body) = annCollectValBinders rhs
+
+annCollectValBinders body
+ = ([], body)
+\end{code}
+
%************************************************************************
%* *
\subsection{Free-To-Level Monad}
newLvlVar :: Type -> LvlM Id
newLvlVar ty us
- = mkSysLocal SLIT("lvl") (getUnique us) ty mkUnknownSrcLoc
+ = mkSysLocal SLIT("lvl") (getUnique us) ty noSrcLoc
\end{code}
projects / ghc-hetmet.git / blobdiff