%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section{SetLevels}
module SetLevels (
setLevels,
- Level(..), tOP_LEVEL,
-
+ Level(..), tOP_LEVEL,
+
incMinorLvl, ltMajLvl, ltLvl, isTopLvl
-- not exported: , incMajorLvl, isTopMajLvl, unTopify
) where
-import PlainCore
-
+import Ubiq{-uitous-}
-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 CoreSyn
+
+import CoreUtils ( coreExprType, manifestlyWHNF, manifestlyBottom )
+import FreeVars -- all of it
+import Id ( idType, mkSysLocal, toplevelishId,
+ nullIdEnv, addOneToIdEnv, growIdEnvList,
+ unionManyIdSets, minusIdSet, mkIdSet,
+ idSetToList,
+ lookupIdEnv, IdEnv(..)
+ )
+import Pretty ( ppStr, ppBesides, ppChar, ppInt )
+import SrcLoc ( mkUnknownSrcLoc )
+import Type ( isPrimType, mkTyVarTys, mkForAllTys )
+import TyVar ( nullTyVarEnv, addOneToTyVarEnv,
+ growTyVarEnvList, lookupTyVarEnv,
+ tyVarSetToList,
+ TyVarEnv(..),
+ unionManyTyVarSets
)
-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
+import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs,
+ mapAndUnzip3Us, getUnique, UniqSM(..)
+ )
+import Usage ( UVar(..) )
+import Util ( mapAccumL, zipWithEqual, panic, assertPanic )
+
+isLeakFreeType = panic "SetLevels.isLeakFreeType (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.
+ | 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. 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 LevelledExpr = GenCoreExpr (Id, Level) Id TyVar UVar
+type LevelledArg = GenCoreArg Id TyVar UVar
+type LevelledBind = GenCoreBinding (Id, Level) Id TyVar UVar
type LevelEnvs = (IdEnv Level, -- bind Ids to levels
TyVarEnv Level) -- bind type variables to levels
-tOP_LEVEL = Top
+tOP_LEVEL = Top
incMajorLvl :: Level -> Level
incMajorLvl Top = Level 1 0
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
%************************************************************************
\begin{code}
-setLevels :: [PlainCoreBinding]
- -> (GlobalSwitch -> Bool) -- access to all global cmd-line opts
- -> SplitUniqSupply
+setLevels :: [CoreBinding]
+ -> UniqSupply
-> [LevelledBind]
-setLevels binds sw us
- = do_them binds sw us
+setLevels binds us
+ = do_them binds us
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 :: [CoreBinding] -> LvlM [LevelledBind]
do_them [] = returnLvl []
do_them (b:bs)
initial_envs = (nullIdEnv, nullTyVarEnv)
--- OLDER:
-lvlTopBind (CoNonRec binder rhs)
- = lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder (freeVars rhs))
+lvlTopBind (NonRec binder rhs)
+ = lvlBind (Level 0 0) initial_envs (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 (Level 0 0) initial_envs (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
+type CoreBindingWithFVs = AnnCoreBinding Id Id TyVar UVar FVInfo
lvlBind :: Level
-> LevelEnvs
-> CoreBindingWithFVs
-> LvlM ([LevelledBind], LevelEnvs)
-lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoNonRec name rhs)
+lvlBind ctxt_lvl envs@(venv, tenv) (AnnNonRec 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)
+ returnLvl ([NonRec (name, final_lvl) rhs'], new_envs)
where
- ty = getIdUniType name
+ ty = idType name
-lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoRec pairs)
+lvlBind ctxt_lvl envs@(venv, tenv) (AnnRec 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)
+ returnLvl (extra_binds ++ [Rec (binders_w_lvls `zip` rhss')], new_envs)
where
(binders,rhss) = unzip pairs
\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 _ _ (_, AnnVar v) = returnLvl (Var v)
+lvlExpr _ _ (_, AnnLit l) = returnLvl (Lit l)
+lvlExpr _ _ (_, AnnCon con args) = returnLvl (Con con args)
+lvlExpr _ _ (_, AnnPrim op args) = returnLvl (Prim op args)
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoApp fun arg)
+lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnApp fun arg)
= lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' ->
- returnLvl (CoApp fun' arg)
+ returnLvl (App fun' arg)
-lvlExpr ctxt_lvl envs (_, AnnCoSCC cc expr)
+lvlExpr ctxt_lvl envs (_, AnnSCC cc expr)
= lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
- returnLvl (CoSCC cc expr')
+ returnLvl (SCC cc expr')
-lvlExpr ctxt_lvl (venv, tenv) (_, AnnCoTyLam tyvar e)
- = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' ->
- returnLvl (CoTyLam tyvar e')
+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')
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')
- 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')
- 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')
+ incd_lvl = incMajorLvl ctxt_lvl
+ new_venv = growIdEnvList venv [(arg,incd_lvl)]
+
+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 = incMajorLvl ctxt_lvl
- args_w_lvls = [ (a, incd_lvl) | a <- args ]
- new_venv = growIdEnvList venv args_w_lvls
+ 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"
-lvlExpr ctxt_lvl envs (_, AnnCoLet bind body)
+lvlExpr ctxt_lvl envs (_, AnnLet 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...
+ returnLvl (foldr Let body' binds') -- mkCoLet* requires Core...
-lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoCase expr alts)
+lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCase expr alts)
= lvlMFE ctxt_lvl envs expr `thenLvl` \ expr' ->
lvl_alts alts `thenLvl` \ alts' ->
- returnLvl (CoCase expr' alts')
+ returnLvl (Case expr' alts')
where
- expr_type = typeOfCoreExpr (deAnnotate expr)
+ expr_type = coreExprType (deAnnotate expr)
incd_lvl = incMinorLvl ctxt_lvl
- lvl_alts (AnnCoAlgAlts alts deflt)
+ lvl_alts (AnnAlgAlts alts deflt)
= mapLvl lvl_alt alts `thenLvl` \ alts' ->
lvl_deflt deflt `thenLvl` \ deflt' ->
- returnLvl (CoAlgAlts alts' deflt')
+ returnLvl (AlgAlts alts' deflt')
where
lvl_alt (con, bs, e)
= let
lvlMFE incd_lvl new_envs e `thenLvl` \ e' ->
returnLvl (con, bs', e')
- lvl_alts (AnnCoPrimAlts alts deflt)
+ lvl_alts (AnnPrimAlts alts deflt)
= mapLvl lvl_alt alts `thenLvl` \ alts' ->
lvl_deflt deflt `thenLvl` \ deflt' ->
- returnLvl (CoPrimAlts alts' deflt')
+ returnLvl (PrimAlts alts' deflt')
where
- lvl_alt (lit, e)
+ lvl_alt (lit, e)
= lvlMFE incd_lvl envs e `thenLvl` \ e' ->
returnLvl (lit, e')
- lvl_deflt AnnCoNoDefault = returnLvl CoNoDefault
+ lvl_deflt AnnNoDefault = returnLvl NoDefault
- lvl_deflt (AnnCoBindDefault b expr)
+ lvl_deflt (AnnBindDefault 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')
+ returnLvl (BindDefault (b, incd_lvl) expr')
\end{code}
@lvlMFE@ is just like @lvlExpr@, except that it might let-bind
ctxt_lvl envs 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
-> Level -- of context
- -> LevelEnvs
+ -> LevelEnvs
-> 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)
+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)...
-- If this gives any problems we could restrict the idea to things destined
-- for top level.
- | not alreadyLetBound
+ | not alreadyLetBound
&& (manifestly_whnf || not will_float_past_lambda)
- = -- Pin whnf non-let-bound expressions,
+ = -- Pin whnf non-let-bound expressions,
-- or ones which aren't going anywhere useful
lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
returnLvl (ctxt_lvl, expr')
returnLvl (maybe_unTopify 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 ->
+ -- 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)
-- 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
+ fv_list = idSetToList 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
tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
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
+ ids_only_lvl `ltMajLvl` ctxt_lvl
- worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
- -- if type abstracted
+ 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
+ is_trivial (App e a)
+ | notValArg a = is_trivial e
+ is_trivial (Var _) = True
+ is_trivial _ = False
offending_tyvars = filter offending tv_list
--non_offending_tyvars = filter (not . offending) tv_list
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]
- -}
+ -- 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]
+ -}
\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
+abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
= lvlExpr incd_lvl new_envs 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 = mkTyLam offending_tyvars expr'
+ poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
+ poly_var_app = mkTyApp (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))
+ next lvl tyvar = (lvl1, (tyvar,lvl1))
where lvl1 = incMinorLvl lvl
new_tenv = growTyVarEnvList tenv tyvar_lvls
x1 = e1
...
xn = en
- in
+ in
body
to
- letrec
+ letrec
x1' = /\ ab -> let D' in e1
...
xn' = /\ ab -> let D' in en
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}
-}
| 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))
+ next lvl tyvar = (lvl1, (tyvar,lvl1))
where lvl1 = incMinorLvl lvl
- ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
+ 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)
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 = 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 = [ mkTyApp (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 NonRec ids_w_incd_lvl d_rhss
- poly_var_rhss = [ mkCoTyLam offending_tyvars (foldr CoLet rhs' local_binds)
- | rhs' <- rhss' -- mkCoLet* requires PlainCore...
+ 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
-
+
in
- returnLvl (ctxt_lvl, [CoRec poly_binds], d_rhss)
+ returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
-- The new right-hand sides, just a type application, aren't worth floating
-- so pin it with ctxt_lvl
returnLvl (expr_lvl, [], rhss')
where
- tys = map getIdUniType ids
+ tys = map idType ids
- fvs = unionManyUniqSets [freeVarsOf rhs | rhs <- rhss] `minusUniqSet` mkUniqSet ids
- tfvs = unionManyUniqSets [freeTyVarsOf rhs | rhs <- rhss]
- fv_list = uniqSetToList fvs
- tv_list = uniqSetToList tfvs
+ fvs = unionManyIdSets [freeVarsOf rhs | rhs <- rhss] `minusIdSet` mkIdSet ids
+ tfvs = unionManyTyVarSets [freeTyVarsOf rhs | rhs <- rhss]
+ fv_list = idSetToList fvs
+ tv_list = tyVarSetToList tfvs
ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
- offending_tyvars
+ 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_tys = mkTyVarTys offending_tyvars
+ poly_tys = map (mkForAllTys offending_tyvars) tys
offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
\end{code}
{- ******** OMITTED NOW
isWorthFloating :: Bool -- True <=> already let-bound
- -> PlainCoreExpr -- The expression
+ -> CoreExpr -- The expression
-> Bool
isWorthFloating alreadyLetBound expr
| otherwise = -- No point in adding a fresh let-binding for a WHNF, because
-- floating it isn't beneficial enough.
- isWorthFloatingExpr expr &&
+ isWorthFloatingExpr expr &&
not (manifestlyWHNF expr || manifestlyBottom expr)
********** -}
-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
+isWorthFloatingExpr :: CoreExpr -> Bool
-canFloatToTop :: (UniType, CoreExprWithFVs) -> Bool
+isWorthFloatingExpr (Var v) = False
+isWorthFloatingExpr (Lit lit) = False
+isWorthFloatingExpr (App e arg)
+ | notValArg arg = isWorthFloatingExpr e
+isWorthFloatingExpr (Con con as)
+ | all notValArg as = False -- Just a type application
+isWorthFloatingExpr _ = True
+
+canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
canFloatToTop (ty, (FVInfo _ _ MightLeak, expr)) = isLeakFreeType [] ty
%************************************************************************
\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)
+type LvlM result = UniqSM result
+
+thenLvl = thenUs
+returnLvl = returnUs
+mapLvl = mapUs
+mapAndUnzipLvl = mapAndUnzipUs
+mapAndUnzip3Lvl = mapAndUnzip3Us
\end{code}
We create a let-binding for `interesting' (non-utterly-trivial)
applications, to give them a fighting chance of being floated.
\begin{code}
-newLvlVar :: UniType -> LvlM Id
+newLvlVar :: Type -> LvlM Id
-newLvlVar ty sw us
- = id
- where
- id = mkSysLocal SLIT("lvl") uniq ty mkUnknownSrcLoc
- uniq = getSUnique us
+newLvlVar ty us
+ = mkSysLocal SLIT("lvl") (getUnique us) ty mkUnknownSrcLoc
\end{code}
projects / ghc-hetmet.git / blobdiff