X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSetLevels.lhs;h=c41fecb83871ca22df2b73b5f3d3518ed4325ef7;hb=edd06d674dd5ffa05c08b6d75dd3a6b63b016f58;hp=e9a0336ef66fe69aa69e874e1684a24642640fc6;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index e9a0336..c41fecb 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -1,50 +1,56 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section{SetLevels} -We attach binding levels to Core bindings, in preparation for floating -outwards (@FloatOut@). + *************************** + Overview + *************************** -We also let-ify many applications (notably case scrutinees), so they -will have a fighting chance of being floated sensible. +* We attach binding levels to Core bindings, in preparation for floating + outwards (@FloatOut@). -\begin{code} -#include "HsVersions.h" +* We also let-ify many expressions (notably case scrutinees), so they + will have a fighting chance of being floated sensible. + +* 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. + + +\begin{code} module SetLevels ( setLevels, - Level(..), tOP_LEVEL, - + Level(..), tOP_LEVEL, + incMinorLvl, ltMajLvl, ltLvl, isTopLvl --- not exported: , incMajorLvl, isTopMajLvl, unTopify ) where -import PlainCore - - -import AbsUniType ( isPrimType, isLeakFreeType, mkTyVarTy, - quantifyTy, TyVarTemplate -- Needed for quantifyTy - ) -import AnnCoreSyn -import BasicLit ( BasicLit(..) ) -import CmdLineOpts ( GlobalSwitch(..) ) -import FreeVars -import Id ( mkSysLocal, getIdUniType, eqId, - isBottomingId, toplevelishId, DataCon(..) - IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) - ) -import IdEnv -import Maybes ( Maybe(..) ) -import Pretty -- debugging only -import PrimKind ( PrimKind(..) ) -import UniqSet -import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) -import TyVarEnv -import SplitUniq -import Unique -import Util +#include "HsVersions.h" + +import CoreSyn + +import CoreUtils ( coreExprType, exprIsTrivial, exprIsBottom ) +import CoreFVs -- all of it +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 VarSet +import VarEnv +import UniqSupply +import Maybes ( maybeToBool ) +import Util ( zipWithEqual, zipEqual ) +import Outputable + +isLeakFreeType x y = False -- safe option; ToDo \end{code} %************************************************************************ @@ -54,19 +60,20 @@ import Util %************************************************************************ \begin{code} -data Level = Level - Int -- Level number of enclosing lambdas - Int -- Number of big-lambda and/or case expressions between - -- here and the nearest enclosing lambda - - | Top -- Means *really* the top level. +data Level + = Top -- Means *really* the top level; short for (Level 0 0). + | Level Int -- Level number of enclosing lambdas + Int -- Number of big-lambda and/or case expressions between + -- here and the nearest enclosing lambda \end{code} - + The {\em level number} on a (type-)lambda-bound variable is the -nesting depth of the (type-)lambda which binds it. On an expression, it's the -maximum level number of its free (type-)variables. On a let(rec)-bound -variable, it's the level of its RHS. On a case-bound variable, it's -the number of enclosing lambdas. +nesting depth of the (type-)lambda which binds it. The outermost lambda +has level 1, so (Level 0 0) means that the variable is bound outside any lambda. + +On an expression, it's the maximum level number of its free +(type-)variables. On a let(rec)-bound variable, it's the level of its +RHS. On a case-bound variable, it's the number of enclosing lambdas. Top-level variables: level~0. Those bound on the RHS of a top-level definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown @@ -76,24 +83,22 @@ a_0 = let b_? = ... in x_1 = ... b ... in ... \end{verbatim} -Level 0 0 will make something get floated to a top-level "equals", @Top@ -makes it go right to the top. +Level 0 0 will make something get floated to a top-level "equals", +@Top@ makes it go right to the top. -The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@). That's -meant to be the level number of the enclosing binder in the final (floated) -program. If the level number of a sub-expression is less than that of the -context, then it might be worth let-binding the sub-expression so that it -will indeed float. This context level starts at @Level 0 0@; it is never @Top@. +The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@). +That's meant to be the level number of the enclosing binder in the +final (floated) program. If the level number of a sub-expression is +less than that of the context, then it might be worth let-binding the +sub-expression so that it will indeed float. This context level starts +at @Level 0 0@; it is never @Top@. \begin{code} -type LevelledExpr = CoreExpr (Id, Level) Id -type LevelledAtom = CoreAtom Id -type LevelledBind = CoreBinding (Id, Level) Id - -type LevelEnvs = (IdEnv Level, -- bind Ids to levels - TyVarEnv Level) -- bind type variables to levels +type LevelledExpr = TaggedExpr Level +type LevelledArg = TaggedArg Level +type LevelledBind = TaggedBind Level -tOP_LEVEL = Top +tOP_LEVEL = Top incMajorLvl :: Level -> Level incMajorLvl Top = Level 1 0 @@ -103,41 +108,44 @@ incMinorLvl :: Level -> Level incMinorLvl Top = Level 0 1 incMinorLvl (Level major minor) = Level major (minor+1) +unTopify :: Type -> Level -> Level +unTopify ty lvl + | isUnLiftedType ty = case lvl of + Top -> Level 0 0 -- Unboxed floats can't go right + other -> lvl -- to the top + | otherwise = lvl + maxLvl :: Level -> Level -> Level maxLvl Top l2 = l2 maxLvl l1 Top = l1 -maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2) +maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2) | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 | otherwise = l2 ltLvl :: Level -> Level -> Bool ltLvl l1 Top = False ltLvl Top (Level _ _) = True -ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) || - (maj1 == maj2 && min1 < min2) +ltLvl (Level maj1 min1) (Level maj2 min2) + = (maj1 < maj2) || (maj1 == maj2 && min1 < min2) -ltMajLvl :: Level -> Level -> Bool -- Tells if one level belongs to a difft - -- *lambda* level to another +ltMajLvl :: Level -> Level -> Bool + -- Tells if one level belongs to a difft *lambda* level to another ltMajLvl l1 Top = False ltMajLvl Top (Level 0 _) = False ltMajLvl Top (Level _ _) = True -ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2 +ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2 isTopLvl :: Level -> Bool isTopLvl Top = True isTopLvl other = False -isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level +isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level isTopMajLvl Top = True isTopMajLvl (Level maj _) = maj == 0 -unTopify :: Level -> Level -unTopify Top = Level 0 0 -unTopify lvl = lvl - instance Outputable Level where - ppr sty Top = ppStr "" - ppr sty (Level maj min) = ppBesides [ ppChar '<', ppInt maj, ppChar ',', ppInt min, ppChar '>' ] + ppr Top = ptext SLIT("") + ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ] \end{code} %************************************************************************ @@ -147,46 +155,30 @@ instance Outputable Level where %************************************************************************ \begin{code} -setLevels :: [PlainCoreBinding] - -> (GlobalSwitch -> Bool) -- access to all global cmd-line opts - -> SplitUniqSupply +setLevels :: [CoreBind] + -> UniqSupply -> [LevelledBind] -setLevels binds sw us - = do_them binds sw us +setLevels binds us + = initLvl us (do_them binds) where -- "do_them"'s main business is to thread the monad along -- It gives each top binding the same empty envt, because -- things unbound in the envt have level number zero implicitly - do_them :: [PlainCoreBinding] -> LvlM [LevelledBind] + do_them :: [CoreBind] -> LvlM [LevelledBind] do_them [] = returnLvl [] do_them (b:bs) = lvlTopBind b `thenLvl` \ (lvld_bind, _) -> - do_them bs `thenLvl` \ lvld_binds -> + do_them bs `thenLvl` \ lvld_binds -> returnLvl (lvld_bind ++ lvld_binds) -initial_envs = (nullIdEnv, nullTyVarEnv) - --- OLDER: -lvlTopBind (CoNonRec binder rhs) - = lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder (freeVars rhs)) +lvlTopBind (NonRec binder rhs) + = lvlBind Top initialEnv (AnnNonRec binder (freeVars rhs)) -- Rhs can have no free vars! -lvlTopBind (CoRec pairs) - = lvlBind (Level 0 0) initial_envs (AnnCoRec [(b,freeVars rhs) | (b,rhs) <- pairs]) - -{- NEWER: Too bad about the types: WDP: -lvlTopBind (CoNonRec binder rhs) - = {-SIGH:wrong type: ASSERT(isEmptyUniqSet (freeVarsOf rhs))-} -- Rhs can have no free vars! - lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder emptyUniqSet) - -lvlTopBind (CoRec pairs) - = lvlBind (Level 0 0) initial_envs - (AnnCoRec [(b, emptyUniqSet) - | (b, rhs) <- pairs, - {-SIGH:ditto:ASSERT(isEmptyUniqSet (freeVarsOf rhs))-} True]) --} +lvlTopBind (Rec pairs) + = lvlBind Top initialEnv (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs]) \end{code} %************************************************************************ @@ -198,34 +190,20 @@ lvlTopBind (CoRec pairs) The binding stuff works for top level too. \begin{code} -type CoreBindingWithFVs = AnnCoreBinding Id Id FVInfo - lvlBind :: Level - -> LevelEnvs - -> CoreBindingWithFVs - -> LvlM ([LevelledBind], LevelEnvs) - -lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoNonRec name rhs) - = setFloatLevel True {- Already let-bound -} - ctxt_lvl envs rhs ty `thenLvl` \ (final_lvl, rhs') -> - let - new_envs = (addOneToIdEnv venv name final_lvl, tenv) - in - returnLvl ([CoNonRec (name, final_lvl) rhs'], new_envs) + -> LevelEnv + -> CoreBindWithFVs + -> LvlM ([LevelledBind], LevelEnv) + +lvlBind ctxt_lvl env (AnnNonRec bndr rhs) + = setFloatLevel (Just bndr) ctxt_lvl env rhs ty `thenLvl` \ (final_lvl, rhs') -> + cloneVar ctxt_lvl env bndr final_lvl `thenLvl` \ (new_env, new_bndr) -> + returnLvl ([NonRec (new_bndr, final_lvl) rhs'], new_env) where - ty = getIdUniType name + ty = idType bndr -lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoRec pairs) - = decideRecFloatLevel ctxt_lvl envs binders rhss - `thenLvl` \ (final_lvl, extra_binds, rhss') -> - let - binders_w_lvls = binders `zip` repeat final_lvl - new_envs = (growIdEnvList venv binders_w_lvls, tenv) - in - returnLvl (extra_binds ++ [CoRec (binders_w_lvls `zip` rhss')], new_envs) - where - (binders,rhss) = unzip pairs +lvlBind ctxt_lvl env (AnnRec pairs) = lvlRecBind ctxt_lvl env pairs \end{code} %************************************************************************ @@ -236,7 +214,7 @@ lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoRec pairs) \begin{code} lvlExpr :: Level -- ctxt_lvl: Level of enclosing expression - -> LevelEnvs -- Level of in-scope names/tyvars + -> LevelEnv -- Level of in-scope names/tyvars -> CoreExprWithFVs -- input expression -> LvlM LevelledExpr -- Result expression \end{code} @@ -259,100 +237,72 @@ don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE If there were another lambda in @r@'s rhs, it would get level-2 as well. \begin{code} -lvlExpr _ _ (_, AnnCoVar v) = returnLvl (CoVar v) -lvlExpr _ _ (_, AnnCoLit l) = returnLvl (CoLit l) -lvlExpr _ _ (_, AnnCoCon con tys atoms) = returnLvl (CoCon con tys atoms) -lvlExpr _ _ (_, AnnCoPrim op tys atoms) = returnLvl (CoPrim op tys atoms) - -lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoTyApp expr ty) - = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' -> - returnLvl (CoTyApp expr' ty) - -lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoApp fun arg) - = lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' -> - returnLvl (CoApp fun' arg) - -lvlExpr ctxt_lvl envs (_, AnnCoSCC cc expr) - = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' -> - returnLvl (CoSCC cc expr') - -lvlExpr ctxt_lvl (venv, tenv) (_, AnnCoTyLam tyvar e) - = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' -> - returnLvl (CoTyLam tyvar e') - where - incd_lvl = incMinorLvl ctxt_lvl - new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl - -{- if we were splitting lambdas: -lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam [arg] rhs) - = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' -> - returnLvl (CoLam arg_w_lvl rhs') +lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty) +lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v) + +lvlExpr ctxt_lvl env (_, AnnCon con args) + = mapLvl (lvlExpr ctxt_lvl env) args `thenLvl` \ args' -> + returnLvl (Con con args') + +lvlExpr ctxt_lvl env (_, AnnApp fun arg) + = lvlExpr ctxt_lvl env fun `thenLvl` \ fun' -> + lvlMFE ctxt_lvl env arg `thenLvl` \ arg' -> + returnLvl (App fun' arg') + +lvlExpr ctxt_lvl env (_, AnnNote note expr) + = lvlExpr ctxt_lvl env expr `thenLvl` \ 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 env (_, AnnLam bndr rhs) + = lvlMFE incd_lvl new_env body `thenLvl` \ body' -> + returnLvl (mkLams lvld_bndrs body') where - incd_lvl = incMajorLvl ctxt_lvl - arg_w_lvl = [(arg, incd_lvl)] - new_venv = growIdEnvList venv arg_w_lvl - -lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam (a:args) rhs) - = lvlExpr incd_lvl (new_venv, tenv) (AnnCoLam args rhs) `thenLvl` \ rhs' -> - -- don't use mkCoLam! - returnLvl (CoLam arg_w_lvl 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 + + lvld_bndrs = [(b,incd_lvl) | b <- bndrs] + new_env = extendLvlEnv env lvld_bndrs + + go (_, AnnLam bndr rhs) | bndr_is_id && isId bndr + || bndr_is_tyvar && isTyVar bndr + = case go rhs of { (bndrs, body) -> (bndr:bndrs, body) } + 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' -> + returnLvl (mkLets binds' body') + +lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts) + = lvlMFE ctxt_lvl env expr `thenLvl` \ expr' -> + mapLvl lvl_alt alts `thenLvl` \ alts' -> + returnLvl (Case expr' (case_bndr, incd_lvl) alts') where - incd_lvl = incMajorLvl ctxt_lvl - arg_w_lvl = [(a,incd_lvl)] - new_venv = growIdEnvList venv arg_w_lvl --} - -lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam args rhs) - = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' -> - returnLvl (CoLam args_w_lvls rhs') - where - incd_lvl = incMajorLvl ctxt_lvl - args_w_lvls = [ (a, incd_lvl) | a <- args ] - new_venv = growIdEnvList venv args_w_lvls - -lvlExpr ctxt_lvl envs (_, AnnCoLet bind body) - = lvlBind ctxt_lvl envs bind `thenLvl` \ (binds', new_envs) -> - lvlExpr ctxt_lvl new_envs body `thenLvl` \ body' -> - returnLvl (foldr CoLet body' binds') -- mkCoLet* requires PlainCore... - -lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoCase expr alts) - = lvlMFE ctxt_lvl envs expr `thenLvl` \ expr' -> - lvl_alts alts `thenLvl` \ alts' -> - returnLvl (CoCase expr' alts') - where - expr_type = typeOfCoreExpr (deAnnotate expr) + expr_type = coreExprType (deAnnotate expr) incd_lvl = incMinorLvl ctxt_lvl - - lvl_alts (AnnCoAlgAlts alts deflt) - = mapLvl lvl_alt alts `thenLvl` \ alts' -> - lvl_deflt deflt `thenLvl` \ deflt' -> - returnLvl (CoAlgAlts alts' deflt') - where - lvl_alt (con, bs, e) - = let - bs' = [ (b, incd_lvl) | b <- bs ] - new_envs = (growIdEnvList venv bs', tenv) - in - lvlMFE incd_lvl new_envs e `thenLvl` \ e' -> - returnLvl (con, bs', e') - - lvl_alts (AnnCoPrimAlts alts deflt) - = mapLvl lvl_alt alts `thenLvl` \ alts' -> - lvl_deflt deflt `thenLvl` \ deflt' -> - returnLvl (CoPrimAlts alts' deflt') - where - lvl_alt (lit, e) - = lvlMFE incd_lvl envs e `thenLvl` \ e' -> - returnLvl (lit, e') - - lvl_deflt AnnCoNoDefault = returnLvl CoNoDefault - - lvl_deflt (AnnCoBindDefault b expr) - = let - new_envs = (addOneToIdEnv venv b incd_lvl, tenv) - in - lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' -> - returnLvl (CoBindDefault (b, incd_lvl) expr') + alts_env = extendLvlEnv env [(case_bndr,incd_lvl)] + + lvl_alt (con, bs, rhs) + = let + bs' = [ (b, incd_lvl) | b <- bs ] + new_env = extendLvlEnv alts_env bs' + in + lvlMFE incd_lvl new_env rhs `thenLvl` \ rhs' -> + returnLvl (con, bs', rhs') \end{code} @lvlMFE@ is just like @lvlExpr@, except that it might let-bind @@ -360,21 +310,24 @@ the expression, so that it can itself be floated. \begin{code} lvlMFE :: Level -- Level of innermost enclosing lambda/tylam - -> LevelEnvs -- Level of in-scope names/tyvars + -> LevelEnv -- Level of in-scope names/tyvars -> CoreExprWithFVs -- input expression -> LvlM LevelledExpr -- Result expression -lvlMFE ctxt_lvl envs@(venv,_) ann_expr - | isPrimType ty -- Can't let-bind it - = lvlExpr ctxt_lvl envs ann_expr +lvlMFE ctxt_lvl env (_, AnnType ty) + = returnLvl (Type ty) + +lvlMFE ctxt_lvl env ann_expr + | isUnLiftedType ty -- Can't let-bind it + = lvlExpr ctxt_lvl env ann_expr | otherwise -- Not primitive type so could be let-bound - = setFloatLevel False {- Not already let-bound -} - ctxt_lvl envs ann_expr ty `thenLvl` \ (final_lvl, expr') -> + = setFloatLevel Nothing {- Not already let-bound -} + ctxt_lvl env ann_expr ty `thenLvl` \ (final_lvl, expr') -> returnLvl expr' where - ty = typeOfCoreExpr (deAnnotate ann_expr) -\end{code} + ty = coreExprType (deAnnotate ann_expr) +\end{code} %************************************************************************ @@ -387,44 +340,41 @@ lvlMFE ctxt_lvl envs@(venv,_) ann_expr are being created as let-bindings Decision tree: -Let Bound? +Let Bound? YES. -> (a) try abstracting type variables. If we abstract type variables it will go further, that is, past more lambdas. same as asking if the level number given by the free - variables is less than the level number given by free variables + variables is less than the level number given by free variables and type variables together. - Abstract offending type variables, e.g. + Abstract offending type variables, e.g. change f ty a b to let v = /\ty' -> f ty' a b - in v ty + in v ty so that v' is not stopped by the level number of ty tag the original let with its level number (from its variables and type variables) - NO. is a WHNF? - YES. -> No point in let binding to float a WHNF. - Pin (leave) expression here. - NO. -> Will float past a lambda? - (check using free variables only, not type variables) - YES. -> do the same as (a) above. - NO. -> No point in let binding if it is not going anywhere - Pin (leave) expression here. + NO. is a WHNF? + YES. -> No point in let binding to float a WHNF. + Pin (leave) expression here. + NO. -> Will float past a lambda? + (check using free variables only, not type variables) + YES. -> do the same as (a) above. + NO. -> No point in let binding if it is not going anywhere + 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 + -> LevelEnv -> CoreExprWithFVs -- Original rhs - -> UniType -- Type of rhs + -> Type -- Type of rhs -> LvlM (Level, -- Level to attribute to this let-binding LevelledExpr) -- Final rhs -setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv) - expr@(FVInfo fvs tfvs might_leak, _) ty --- Invariant: ctxt_lvl is never = Top --- Beautiful ASSERT, dudes (WDP 95/04)... +setFloatLevel maybe_let_bound ctxt_lvl env expr@(expr_fvs, _) ty -- Now deal with (by not floating) trivial non-let-bound expressions -- which just aren't worth let-binding in order to float. We always @@ -432,7 +382,7 @@ setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv) -- any harm, and not floating it may pin something important. For -- example -- --- x = let v = Nil +-- x = let v = [] -- w = 1:v -- in ... -- @@ -440,85 +390,66 @@ setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv) -- If this gives any problems we could restrict the idea to things destined -- for top level. - | not alreadyLetBound - && (manifestly_whnf || not will_float_past_lambda) - = -- Pin whnf non-let-bound expressions, + | not alreadyLetBound + && (expr_is_trivial || expr_is_bottom || not will_float_past_lambda) + + = -- Pin trivial non-let-bound expressions, -- or ones which aren't going anywhere useful - lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' -> - returnLvl (ctxt_lvl, expr') + lvlExpr ctxt_lvl env expr `thenLvl` \ expr' -> + returnLvl (safe_ctxt_lvl, expr') + +{- SDM 7/98 +The above case used to read (whnf_or_bottom || not will_float_past_lambda). +It was changed because we really do want to float out constructors if possible: +this can save a great deal of needless allocation inside a loop. On the other +hand, there's no point floating out nullary constructors and literals, hence +the expr_is_trivial condition. +-} | alreadyLetBound && not worth_type_abstraction = -- Process the expression with a new ctxt_lvl, obtained from -- the free vars of the expression itself - lvlExpr (unTopify expr_lvl) envs expr `thenLvl` \ expr' -> - returnLvl (maybe_unTopify expr_lvl, expr') + lvlExpr expr_lvl env expr `thenLvl` \ expr' -> + returnLvl (safe_expr_lvl, expr') | otherwise -- This will create a let anyway, even if there is no - -- type variable to abstract, so we try to abstract anyway - = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr - `thenLvl` \ final_expr -> - returnLvl (expr_lvl, final_expr) + -- type variable to abstract, so we try to abstract anyway + = abstractWrtTyVars offending_tyvars ty env lvl_after_ty_abstr expr + `thenLvl` \ final_expr -> + returnLvl (safe_expr_lvl, final_expr) -- OLD LIE: The body of the let, just a type application, isn't worth floating -- so pin it with ctxt_lvl -- The truth: better to give it expr_lvl in case it is pinning -- something non-trivial which depends on it. where - fv_list = uniqSetToList fvs - tv_list = uniqSetToList tfvs - expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl - ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list - tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list + alreadyLetBound = maybeToBool maybe_let_bound + + safe_ctxt_lvl = unTopify ty ctxt_lvl + safe_expr_lvl = unTopify ty expr_lvl + + fvs = case maybe_let_bound of + Nothing -> expr_fvs + Just id -> expr_fvs `unionVarSet` idFreeVars id + + ids_only_lvl = foldVarSet (maxIdLvl env) tOP_LEVEL fvs + tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL fvs + expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl - will_float_past_lambda = -- Will escape lambda if let-bound - ids_only_lvl `ltMajLvl` ctxt_lvl - - worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s) - -- if type abstracted - (ids_only_lvl `ltLvl` tyvars_only_lvl) - && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications - - de_ann_expr = deAnnotate expr - - is_trivial (CoTyApp e _) = is_trivial e - is_trivial (CoVar _) = True - is_trivial _ = False - - offending_tyvars = filter offending tv_list - --non_offending_tyvars = filter (not . offending) tv_list - --non_offending_tyvars_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL non_offending_tyvars - - offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar - - manifestly_whnf = manifestlyWHNF de_ann_expr || manifestlyBottom de_ann_expr - - maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0 - maybe_unTopify lvl = lvl - {- ToDo [Andre]: the line above (maybe) should be Level 1 0, - -- so that the let will not go past the *last* lambda if it can - -- generate a space leak. If it is already in major level 0 - -- It won't do any harm to give it a Level 1 0. - -- we should do the same test not only for things with level Top, - -- but also for anything that gets a major level 0. - the problem is that - f = \a -> let x = [1..1000] - in zip a x - ==> - f = let x = [1..1000] - in \a -> zip a x - is just as bad as floating x to the top level. - Notice it would be OK in cases like - f = \a -> let x = [1..1000] - y = length x - in a + y - ==> - f = let x = [1..1000] - y = length x - in \a -> a + y - as x will be gc'd after y is updated. - [We did not hit any problems with the above (Level 0 0) code - in nofib benchmark] - -} + -- Will escape lambda if let-bound + will_float_past_lambda = ids_only_lvl `ltMajLvl` ctxt_lvl + + -- Will escape (more) lambda(s)/type lambda(s) if type abstracted + worth_type_abstraction = (ids_only_lvl `ltLvl` tyvars_only_lvl) + && not expr_is_trivial -- Avoids abstracting trivial type applications + + offending_tyvars = filter offending_tv (varSetElems fvs) + offending_tv var | isId var = False + | otherwise = ids_only_lvl `ltLvl` varLevel env var + + expr_is_trivial = exprIsTrivial de_ann_expr + expr_is_bottom = exprIsBottom de_ann_expr + de_ann_expr = deAnnotate expr \end{code} Abstract wrt tyvars, by making it just as if we had seen @@ -531,27 +462,23 @@ has no free type variables. Of course, if E has no free type variables, then we just return E. \begin{code} -abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr - = lvlExpr incd_lvl new_envs expr `thenLvl` \ expr' -> +abstractWrtTyVars offending_tyvars ty env lvl expr + = lvlExpr incd_lvl new_env expr `thenLvl` \ expr' -> newLvlVar poly_ty `thenLvl` \ poly_var -> let - poly_var_rhs = mkCoTyLam offending_tyvars expr' - poly_var_binding = CoNonRec (poly_var, lvl) poly_var_rhs - poly_var_app = mkCoTyApps (CoVar poly_var) (map mkTyVarTy offending_tyvars) - final_expr = CoLet poly_var_binding poly_var_app -- mkCoLet* requires PlainCore + poly_var_rhs = mkLams tyvar_lvls expr' + poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs + poly_var_app = mkTyApps (Var poly_var) (mkTyVarTys offending_tyvars) + final_expr = Let poly_var_binding poly_var_app -- mkCoLet* requires Core in returnLvl final_expr where - poly_ty = snd (quantifyTy offending_tyvars ty) + poly_ty = mkForAllTys offending_tyvars ty -- These defns are just like those in the TyLam case of lvlExpr - (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars - - next lvl tyvar = (lvl1, (tyvar,lvl1)) - where lvl1 = incMinorLvl lvl - - new_tenv = growTyVarEnvList tenv tyvar_lvls - new_envs = (venv, new_tenv) + incd_lvl = incMinorLvl lvl + tyvar_lvls = [(tv,incd_lvl) | tv <- offending_tyvars] + new_env = extendLvlEnv env tyvar_lvls \end{code} Recursive definitions. We want to transform @@ -560,12 +487,12 @@ Recursive definitions. We want to transform x1 = e1 ... xn = en - in + in body to - letrec + letrec x1' = /\ ab -> let D' in e1 ... xn' = /\ ab -> let D' in en @@ -573,10 +500,10 @@ to let D in body where ab are the tyvars pinning the defn further in than it -need be, and D is a bunch of simple type applications: +need be, and D is a bunch of simple type applications: x1_cl = x1' ab - ... + ... xn_cl = xn' ab The "_cl" indicates that in D, the level numbers on the xi are the context level @@ -584,206 +511,175 @@ number; type applications aren't worth floating. The D' decls are similar: x1_ll = x1' ab - ... + ... xn_ll = xn' ab -but differ in their level numbers; here the ab are the newly-introduced +but differ in their level numbers; here the ab are the newly-introduced type lambdas. \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 - = -- Pin it here - let - ids_w_lvls = ids `zip` repeat ctxt_lvl - new_envs = (growIdEnvList venv ids_w_lvls, tenv) - in - mapLvl (lvlExpr ctxt_lvl new_envs) rhss `thenLvl` \ rhss' -> - returnLvl (ctxt_lvl, [], rhss') - -{- OMITTED; see comments above near isWorthFloatingExpr - - | not (any (isWorthFloating True . deAnnotate) rhss) - = -- Pin it here - mapLvl (lvlExpr ctxt_lvl envs) rhss `thenLvl` \ rhss' -> - returnLvl (ctxt_lvl, [], rhss') - --} - +lvlRecBind ctxt_lvl env pairs | ids_only_lvl `ltLvl` tyvars_only_lvl - = -- Abstract wrt tyvars; + = -- Abstract wrt tyvars; -- offending_tyvars is definitely non-empty -- (I love the ASSERT to check this... WDP 95/02) let - -- These defns are just like those in the TyLam case of lvlExpr - (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars - - next lvl tyvar = (lvl1, (tyvar,lvl1)) - where lvl1 = incMinorLvl lvl - - ids_w_incd_lvl = [(id,incd_lvl) | id <- ids] - new_tenv = growTyVarEnvList tenv tyvar_lvls - new_venv = growIdEnvList venv ids_w_incd_lvl - new_envs = (new_venv, new_tenv) + incd_lvl = incMinorLvl ids_only_lvl + tyvars_w_rhs_lvl = [(var,incd_lvl) | var <- offending_tyvars] + bndrs_w_rhs_lvl = [(var,incd_lvl) | var <- bndrs] + rhs_env = extendLvlEnv env (tyvars_w_rhs_lvl ++ bndrs_w_rhs_lvl) in - mapLvl (lvlExpr incd_lvl new_envs) rhss `thenLvl` \ rhss' -> + mapLvl (lvlExpr incd_lvl rhs_env) rhss `thenLvl` \ rhss' -> mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars -> + cloneVars ctxt_lvl env bndrs ctxt_lvl `thenLvl` \ (new_env, new_bndrs) -> let - ids_w_poly_vars = ids `zip` poly_vars - -- The "d_rhss" are the right-hand sides of "D" and "D'" -- in the documentation above - d_rhss = [ mkCoTyApps (CoVar poly_var) offending_tyvar_tys | poly_var <- poly_vars] + d_rhss = [ mkTyApps (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars] -- "local_binds" are "D'" in the documentation above - local_binds = zipWith CoNonRec ids_w_incd_lvl d_rhss + local_binds = zipWithEqual "SetLevels" NonRec bndrs_w_rhs_lvl d_rhss - poly_var_rhss = [ mkCoTyLam offending_tyvars (foldr CoLet rhs' local_binds) - | rhs' <- rhss' -- mkCoLet* requires PlainCore... + poly_var_rhss = [ mkLams tyvars_w_rhs_lvl (mkLets local_binds rhs') + | rhs' <- rhss' ] - 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 + + -- 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 + + -- "d_binds" are the "D" in the documentation above + d_binds = zipWithEqual "SetLevels" NonRec bndrs_w_lvl d_rhss in - returnLvl (ctxt_lvl, [CoRec poly_binds], d_rhss) - -- The new right-hand sides, just a type application, aren't worth floating - -- so pin it with ctxt_lvl + returnLvl (Rec poly_binds : d_binds, new_env) | otherwise = -- Let it float freely + cloneVars ctxt_lvl env bndrs expr_lvl `thenLvl` \ (new_env, new_bndrs) -> let - ids_w_lvls = ids `zip` repeat expr_lvl - new_envs = (growIdEnvList venv ids_w_lvls, tenv) + bndrs_w_lvls = new_bndrs `zip` repeat expr_lvl in - mapLvl (lvlExpr (unTopify expr_lvl) new_envs) rhss `thenLvl` \ rhss' -> - returnLvl (expr_lvl, [], rhss') + mapLvl (lvlExpr expr_lvl new_env) rhss `thenLvl` \ rhss' -> + returnLvl ([Rec (bndrs_w_lvls `zip` rhss')], new_env) where - tys = map getIdUniType ids + (bndrs,rhss) = unzip pairs - fvs = unionManyUniqSets [freeVarsOf rhs | rhs <- rhss] `minusUniqSet` mkUniqSet ids - tfvs = unionManyUniqSets [freeTyVarsOf rhs | rhs <- rhss] - fv_list = uniqSetToList fvs - tv_list = uniqSetToList tfvs + -- Finding the free vars of the binding group is annoying + bind_fvs = (unionVarSets (map fst rhss) `unionVarSet` unionVarSets (map idFreeVars bndrs)) + `minusVarSet` + mkVarSet bndrs - ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list - tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list + ids_only_lvl = foldVarSet (maxIdLvl env) tOP_LEVEL bind_fvs + tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL bind_fvs expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl - offending_tyvars - | ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list - | otherwise = [] - - offending_tyvar_tys = map mkTyVarTy offending_tyvars - poly_tys = [ snd (quantifyTy offending_tyvars ty) - | ty <- tys - ] - - offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar -\end{code} - - -\begin{code} -{- ******** OMITTED NOW - -isWorthFloating :: Bool -- True <=> already let-bound - -> PlainCoreExpr -- The expression - -> Bool - -isWorthFloating alreadyLetBound expr - - | alreadyLetBound = isWorthFloatingExpr expr - - | 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) -********** -} + offending_tyvars = filter offending_tv (varSetElems bind_fvs) + offending_tv var | isId var = False + | otherwise = ids_only_lvl `ltLvl` varLevel env var + offending_tyvar_tys = mkTyVarTys offending_tyvars -isWorthFloatingExpr :: PlainCoreExpr -> Bool -isWorthFloatingExpr (CoVar v) = False -isWorthFloatingExpr (CoLit lit) = False -isWorthFloatingExpr (CoCon con tys []) = False -- Just a type application -isWorthFloatingExpr (CoTyApp expr ty) = isWorthFloatingExpr expr -isWorthFloatingExpr other = True - -canFloatToTop :: (UniType, CoreExprWithFVs) -> Bool - -canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True -canFloatToTop (ty, (FVInfo _ _ MightLeak, expr)) = isLeakFreeType [] ty - -valSuggestsLeakFree expr = manifestlyWHNF expr || manifestlyBottom expr + tys = map idType bndrs + poly_tys = map (mkForAllTys offending_tyvars) tys \end{code} - - %************************************************************************ %* * -\subsection{Help functions} +\subsection{Free-To-Level Monad} %* * %************************************************************************ \begin{code} -idLevel :: IdEnv Level -> Id -> Level -idLevel venv v - = case lookupIdEnv venv v of - Just level -> level - Nothing -> ASSERT(toplevelishId v) - tOP_LEVEL - -tyvarLevel :: TyVarEnv Level -> TyVar -> Level -tyvarLevel tenv tyvar - = case lookupTyVarEnv tenv tyvar of +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 -\end{code} -%************************************************************************ -%* * -\subsection{Free-To-Level Monad} -%* * -%************************************************************************ +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 - = (GlobalSwitch -> Bool) -> SplitUniqSupply -> result - -thenLvl m k sw us - = case splitUniqSupply us of { (s1, s2) -> - case m sw s1 of { m_result -> - k m_result sw s2 }} - -returnLvl v sw us = v - -mapLvl f [] = returnLvl [] -mapLvl f (x:xs) - = f x `thenLvl` \ r -> - mapLvl f xs `thenLvl` \ rs -> - returnLvl (r:rs) - -mapAndUnzipLvl f [] = returnLvl ([], []) -mapAndUnzipLvl f (x:xs) - = f x `thenLvl` \ (r1, r2) -> - mapAndUnzipLvl f xs `thenLvl` \ (rs1, rs2) -> - returnLvl (r1:rs1, r2:rs2) - -mapAndUnzip3Lvl f [] = returnLvl ([], [], []) -mapAndUnzip3Lvl f (x:xs) - = f x `thenLvl` \ (r1, r2, r3) -> - mapAndUnzip3Lvl f xs `thenLvl` \ (rs1, rs2, rs3) -> - returnLvl (r1:rs1, r2:rs2, r3:rs3) -\end{code} +type LvlM result = UniqSM result -We create a let-binding for `interesting' (non-utterly-trivial) -applications, to give them a fighting chance of being floated. +initLvl = initUs_ +thenLvl = thenUs +returnLvl = returnUs +mapLvl = mapUs +\end{code} \begin{code} -newLvlVar :: UniType -> LvlM Id +newLvlVar :: Type -> LvlM Id +newLvlVar ty = getUniqueUs `thenLvl` \ uniq -> + returnUs (mkSysLocal SLIT("lvl") uniq ty) + +-- The deeply tiresome thing is that we have to apply the substitution +-- to the rules inside each Id. Grr. But it matters. + +cloneVar :: Level -> LevelEnv -> Id -> Level -> LvlM (LevelEnv, Id) +cloneVar Top env v lvl + = returnUs (env, v) -- Don't clone top level things +cloneVar _ (lvl_env, subst_env) v lvl + = getUniqueUs `thenLvl` \ uniq -> + let + subst = mkSubst emptyVarSet subst_env + v' = setVarUnique v uniq + v'' = apply_to_rules subst 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 :: Level -> LevelEnv -> [Id] -> Level -> LvlM (LevelEnv, [Id]) +cloneVars Top env vs lvl + = returnUs (env, vs) -- Don't clone top level things +cloneVars _ (lvl_env, subst_env) vs lvl + = getUniquesUs (length vs) `thenLvl` \ uniqs -> + let + subst = mkSubst emptyVarSet subst_env' + vs' = zipWith setVarUnique vs uniqs + vs'' = map (apply_to_rules subst) 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'') -newLvlVar ty sw us - = id +-- Apply the substitution to the rules +apply_to_rules subst id + = modifyIdInfo go_spec id where - id = mkSysLocal SLIT("lvl") uniq ty mkUnknownSrcLoc - uniq = getSUnique us + go_spec info = info `setSpecInfo` substRules subst (specInfo info) \end{code}