%
-% (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}
%************************************************************************
%************************************************************************
\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
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
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 "<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}
%************************************************************************
%************************************************************************
\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}
%************************************************************************
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}
%************************************************************************
\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}
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
\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}
%************************************************************************
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
-- any harm, and not floating it may pin something important. For
-- example
--
--- x = let v = Nil
+-- x = let v = []
-- w = 1:v
-- in ...
--
-- 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
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
x1 = e1
...
xn = en
- in
+ in
body
to
- letrec
+ letrec
x1' = /\ ab -> let D' in e1
...
xn' = /\ ab -> let D' in en
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
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}
projects / ghc-hetmet.git / blobdiff