X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSetLevels.lhs;h=6391e4b090c2bcebff033eaf04c1958af2003de1;hb=4416c105bb26ac9176c27a9f7c7e4579933e56e9;hp=23edaed052ef299dba1e17790d4792049aae6b13;hpb=375001f6a1a98d2159986b6bbd79e35323faa052;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 23edaed..6391e4b 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -10,49 +10,45 @@ We also let-ify many applications (notably case scrutinees), so they 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} @@ -96,9 +92,9 @@ sub-expression so that it will indeed float. This context level starts 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 @@ -146,8 +142,8 @@ unTopify Top = Level 0 0 unTopify lvl = lvl instance Outputable Level where - ppr sty Top = ptext SLIT("") - ppr sty (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ] + ppr Top = ptext SLIT("") + ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ] \end{code} %************************************************************************ @@ -175,7 +171,7 @@ setLevels binds us 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)) @@ -194,7 +190,7 @@ lvlTopBind (Rec pairs) 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 @@ -202,7 +198,7 @@ lvlBind :: Level -> 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) @@ -264,13 +260,9 @@ lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnApp fun arg) = 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) @@ -296,10 +288,7 @@ lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) body) 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) -> @@ -356,11 +345,11 @@ lvlMFE :: Level -- Level of innermost enclosing lambda/tylam -> 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 @@ -401,8 +390,8 @@ Let Bound? 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 @@ -412,7 +401,7 @@ setFloatLevel :: Bool -- True <=> the expression is already let-bound -> 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)... @@ -454,7 +443,16 @@ setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv) -- 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 @@ -655,7 +653,10 @@ decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids 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