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
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
import AnnCoreSyn
import CoreSyn
-import CoreUtils ( coreExprType )
+import CoreUtils ( coreExprType, idSpecVars )
import CoreUnfold ( FormSummary, whnfOrBottom, mkFormSummary )
import FreeVars -- all of it
-import Id ( idType, mkSysLocal,
+import MkId ( mkSysLocal )
+import Id ( idType,
nullIdEnv, addOneToIdEnv, growIdEnvList,
- unionManyIdSets, minusIdSet, mkIdSet,
- idSetToList, SYN_IE(Id),
- lookupIdEnv, SYN_IE(IdEnv)
+ unionManyIdSets, unionIdSets, minusIdSet, mkIdSet,
+ idSetToList, Id,
+ lookupIdEnv, IdEnv
)
-import Pretty ( ptext, hcat, char, int )
import SrcLoc ( noSrcLoc )
-import Type ( isPrimType, mkTyVarTys, mkForAllTys, tyVarsOfTypes, SYN_IE(Type) )
-import TyVar ( nullTyVarEnv, addOneToTyVarEnv,
+import Type ( isUnpointedType, mkTyVarTys, mkForAllTys, tyVarsOfTypes, Type )
+import TyVar ( emptyTyVarEnv, addToTyVarEnv,
growTyVarEnvList, lookupTyVarEnv,
tyVarSetToList,
- SYN_IE(TyVarEnv), SYN_IE(TyVar),
+ TyVarEnv, TyVar,
unionManyTyVarSets, unionTyVarSets
)
import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs,
- mapAndUnzip3Us, getUnique, SYN_IE(UniqSM),
+ mapAndUnzip3Us, getUnique, UniqSM,
UniqSupply
)
-import Usage ( SYN_IE(UVar) )
+import BasicTypes ( Unused )
+import Maybes ( maybeToBool )
import Util ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic )
-#if __GLASGOW_HASKELL__ >= 202
-import Outputable ( Outputable(..) )
-#endif
+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 = ptext SLIT("<Top>")
- ppr sty (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
+ 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
-> LvlM ([LevelledBind], LevelEnvs)
lvlBind ctxt_lvl envs@(venv, tenv) (AnnNonRec name rhs)
- = setFloatLevel True {- Already let-bound -}
+ = setFloatLevel (Just name) {- Already let-bound -}
ctxt_lvl envs rhs ty `thenLvl` \ (final_lvl, rhs') ->
let
new_envs = (addOneToIdEnv venv name final_lvl, tenv)
= lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' ->
returnLvl (App fun' arg)
-lvlExpr ctxt_lvl envs (_, AnnSCC cc expr)
- = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
- returnLvl (SCC cc expr')
-
-lvlExpr ctxt_lvl envs (_, AnnCoerce c ty expr)
+lvlExpr ctxt_lvl envs (_, AnnNote note expr)
= lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
- returnLvl (Coerce c ty expr')
+ returnLvl (Note note expr')
-- We don't split adjacent lambdas. That is, given
-- \x y -> (x+1,y)
returnLvl (Lam (TyBinder tyvar) body')
where
incd_lvl = incMinorLvl ctxt_lvl
- new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
-
-lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (UsageBinder u) e)
- = panic "SetLevels.lvlExpr:AnnLam UsageBinder"
+ 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
- = setFloatLevel False {- Not already let-bound -}
+ = setFloatLevel Nothing {- Not already let-bound -}
ctxt_lvl envs ann_expr ty `thenLvl` \ (final_lvl, expr') ->
returnLvl expr'
where
Pin (leave) expression here.
\begin{code}
-setFloatLevel :: Bool -- True <=> the expression is already let-bound
- -- False <=> it's a possible MFE
+setFloatLevel :: Maybe Id -- Just id <=> the expression is already let-bound to id
+ -- Nothing <=> it's a possible MFE
-> Level -- of context
-> LevelEnvs
-> LvlM (Level, -- Level to attribute to this let-binding
LevelledExpr) -- Final rhs
-setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
+setFloatLevel maybe_let_bound ctxt_lvl envs@(venv, tenv)
expr@(FVInfo fvs tfvs might_leak, _) ty
-- Invariant: ctxt_lvl is never = Top
-- Beautiful ASSERT, dudes (WDP 95/04)...
-- The truth: better to give it expr_lvl in case it is pinning
-- something non-trivial which depends on it.
where
- fv_list = idSetToList fvs
+ alreadyLetBound = maybeToBool maybe_let_bound
+
+
+
+ real_fvs = case maybe_let_bound of
+ Nothing -> fvs -- Just the expr fvs
+ Just id -> fvs `unionIdSets` mkIdSet (idSpecVars id)
+ -- Tiresome! Add the specVars
+
+ fv_list = idSetToList real_fvs
tv_list = tyVarSetToList tfvs
expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
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
projects / ghc-hetmet.git / blobdiff