Commit f659cb97 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-10-03 13:58:50 by simonpj]

---------------------
	Clear up infelicities
	---------------------
	CorePrep, CoreUtils, SimplUtils
	LiberateCase (wibbles only)

* Previously CorePrep was floating LocalIds to top level, which
  breaks the invariant that after CorePrep all top level Ids are
  GlobalIds.  But it didn't really need to, and this pass makes it
  so.  It's much tidier now.

* Make CorePrep do eta expansion on partial applications
	x = foldr f y  ==>   x = \ys -> foldr f y ys
  (This used to be done in the simplifier, but now the
  simplifier only eta expands where there is at least one
  lambda already.)

* Omit CoreUtils.etaReduce.  (Never called.)

* Improve CoreUtils.etaExpand, so that it doesn't add gratuitous
  beta redexes.
parent 4a1e12a1
......@@ -10,7 +10,7 @@ module CorePrep (
#include "HsVersions.h"
import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand, exprOkForSpeculation )
import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
......@@ -26,7 +26,6 @@ import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
setIdType, isPrimOpId_maybe, isFCallId, isLocalId,
hasNoBinding, idNewStrictness
)
import BasicTypes( TopLevelFlag(..), isNotTopLevel )
import HscTypes ( ModDetails(..) )
import UniqSupply
import Maybes
......@@ -107,14 +106,18 @@ data FloatingBind = FloatLet CoreBind
| FloatCase Id CoreExpr Bool
-- The bool indicates "ok-for-speculation"
instance Outputable FloatingBind where
ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
type CloneEnv = IdEnv Id -- Clone local Ids
allLazy :: TopLevelFlag -> OrdList FloatingBind -> Bool
allLazy top_lvl floats
allLazy :: OrdList FloatingBind -> Bool
allLazy floats
= foldrOL check True floats
where
check (FloatLet _) y = y
check (FloatCase _ _ ok_for_spec) y = isNotTopLevel top_lvl && ok_for_spec && y
check (FloatCase _ _ ok_for_spec) y = ok_for_spec && y
-- The ok-for-speculation flag says that it's safe to
-- float this Case out of a let, and thereby do it more eagerly
-- We need the top-level flag because it's never ok to float
......@@ -128,15 +131,45 @@ corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind]
corePrepTopBinds env [] = returnUs []
corePrepTopBinds env (bind : binds)
= corePrepBind TopLevel env bind `thenUs` \ (env', floats) ->
ASSERT( allLazy TopLevel floats )
= corePrepTopBind env bind `thenUs` \ (env', bind') ->
corePrepTopBinds env' binds `thenUs` \ binds' ->
returnUs (foldrOL add binds' floats)
returnUs (bind' : binds')
-- From top level bindings we don't get any floats
-- (a) it isn't necessary because the mkAtomicArgs in Simplify
-- has already done all the floating necessary
-- (b) floating would give rise to top-level LocaIds, generated
-- by CorePrep.newVar. That breaks the invariant that
-- after CorePrep all top-level vars are GlobalIds
corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, CoreBind)
corePrepTopBind env (NonRec bndr rhs)
= corePrepRhs env (bndr, rhs) `thenUs` \ rhs' ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
returnUs (env', NonRec bndr' rhs')
corePrepTopBind env (Rec pairs)
= corePrepRecPairs env pairs `thenUs` \ (env', pairs') ->
returnUs (env, Rec pairs')
corePrepRecPairs env pairs
= cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
mapUs (corePrepRhs env') pairs `thenUs` \ rhss' ->
returnUs (env', bndrs' `zip` rhss')
where
add (FloatLet bind) binds = bind : binds
bndrs = map fst pairs
corePrepRhs :: CloneEnv -> (Id, CoreExpr) -> UniqSM CoreExpr
corePrepRhs env (bndr, rhs)
-- Prepare the RHS and eta expand it.
-- No nonsense about floating
= corePrepAnExpr env rhs `thenUs` \ rhs' ->
getUniquesUs `thenUs` \ us ->
returnUs (etaExpand (exprArity rhs') us rhs' (idType bndr))
corePrepBind :: TopLevelFlag -> CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
-- This one is used for *local* bindings
-- We return a *list* of bindings, because we may start with
-- x* = f (g y)
-- where x is demanded, in which case we want to finish with
......@@ -144,21 +177,17 @@ corePrepBind :: TopLevelFlag -> CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdLis
-- x* = f a
-- And then x will actually end up case-bound
corePrepBind top_lvl env (NonRec bndr rhs)
corePrepBind env (NonRec bndr rhs)
= corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
mkNonRec top_lvl bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
mkLocalNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
returnUs (env', floats')
corePrepBind top_lvl env (Rec pairs)
corePrepBind env (Rec pairs)
-- Don't bother to try to float bindings out of RHSs
-- (compare mkNonRec, which does try)
= cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
mapUs (corePrepAnExpr env') rhss `thenUs` \ rhss' ->
returnUs (env', unitOL (FloatLet (Rec (bndrs' `zip` rhss'))))
where
(bndrs, rhss) = unzip pairs
= corePrepRecPairs env pairs `thenUs` \ (env', pairs') ->
returnUs (env', unitOL (FloatLet (Rec pairs')))
-- ---------------------------------------------------------------------------
-- Making arguments atomic (function args & constructor args)
......@@ -171,8 +200,8 @@ corePrepArg env arg dem
= corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
if needs_binding arg'
then returnUs (floats, arg')
else newVar (exprType arg') `thenUs` \ v ->
mkNonRec NotTopLevel v dem floats arg' `thenUs` \ floats' ->
else newVar (exprType arg') `thenUs` \ v ->
mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
returnUs (floats', Var v)
needs_binding | opt_RuntimeTypes = exprIsAtom
......@@ -222,8 +251,8 @@ corePrepExprFloat env expr@(Lit lit)
= returnUs (nilOL, expr)
corePrepExprFloat env (Let bind body)
= corePrepBind NotTopLevel env bind `thenUs` \ (env', new_binds) ->
corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
= corePrepBind env bind `thenUs` \ (env', new_binds) ->
corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
returnUs (new_binds `appOL` floats, new_body)
corePrepExprFloat env (Note n@(SCC _) expr)
......@@ -325,9 +354,9 @@ corePrepExprFloat env expr@(App _ _)
-- non-variable fun, better let-bind it
collect_args fun depth
= corePrepExprFloat env fun `thenUs` \ (fun_floats, fun) ->
newVar ty `thenUs` \ fn_id ->
mkNonRec NotTopLevel fn_id onceDem fun_floats fun `thenUs` \ floats ->
= corePrepExprFloat env fun `thenUs` \ (fun_floats, fun) ->
newVar ty `thenUs` \ fn_id ->
mkLocalNonRec fn_id onceDem fun_floats fun `thenUs` \ floats ->
returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
where
ty = exprType fun
......@@ -346,24 +375,24 @@ corePrepExprFloat env expr@(App _ _)
maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
maybeSaturate fn expr n_args ty
| hasNoBinding fn = saturate_it
| otherwise = returnUs expr
| otherwise = returnUs expr
where
fn_arity = idArity fn
excess_arity = fn_arity - n_args
saturate_it = getUs `thenUs` \ us ->
returnUs (etaExpand excess_arity (uniqsFromSupply us) expr ty)
saturate_it = getUniquesUs `thenUs` \ us ->
returnUs (etaExpand excess_arity us expr ty)
-- ---------------------------------------------------------------------------
-- Precipitating the floating bindings
-- ---------------------------------------------------------------------------
-- mkNonRec is used for both top level and local bindings
mkNonRec :: TopLevelFlag
-> Id -> RhsDemand -- Lhs: id with demand
-> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
-> UniqSM (OrdList FloatingBind)
mkNonRec top_lvl bndr dem floats rhs
| exprIsValue rhs && allLazy top_lvl floats -- Notably constructor applications
-- mkLocalNonRec is used only for local bindings
mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
-> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
-> UniqSM (OrdList FloatingBind)
mkLocalNonRec bndr dem floats rhs
| exprIsValue rhs && allLazy floats -- Notably constructor applications
= -- Why the test for allLazy? You might think that the only
-- floats we can get out of a value are eta expansions
-- e.g. C $wJust ==> let s = \x -> $wJust x in C s
......@@ -385,7 +414,19 @@ mkNonRec top_lvl bndr dem floats rhs
-- v = f (x `divInt#` y)
-- we don't want to float the case, even if f has arity 2,
-- because floating the case would make it evaluated too early
returnUs (floats `snocOL` FloatLet (NonRec bndr rhs))
--
-- Finally, eta-expand the RHS, for the benefit of the code gen
-- NB: we could refrain when the RHS is trivial (which can happen
-- for exported things. This would reduce the amount of code
-- generated (a little) and make things a little words for
-- code compiled without -O. The case in point is data constructor
-- wrappers.
--
getUniquesUs `thenUs` \ us ->
let
rhs' = etaExpand (exprArity rhs) us rhs bndr_ty
in
returnUs (floats `snocOL` FloatLet (NonRec bndr rhs'))
| isUnLiftedType bndr_rep_ty || isStrict dem
-- It's a strict let, or the binder is unlifted,
......@@ -394,12 +435,13 @@ mkNonRec top_lvl bndr dem floats rhs
returnUs (floats `snocOL` FloatCase bndr rhs (exprOkForSpeculation rhs))
| otherwise
-- Don't float
-- Don't float; the RHS isn't a value
= mkBinds floats rhs `thenUs` \ rhs' ->
returnUs (unitOL (FloatLet (NonRec bndr rhs')))
where
bndr_rep_ty = repType (idType bndr)
bndr_ty = idType bndr
bndr_rep_ty = repType bndr_ty
mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
mkBinds binds body
......
......@@ -22,8 +22,7 @@ module CoreUtils (
exprArity,
-- Expr transformation
etaReduce, etaExpand,
exprArity, exprEtaExpandArity,
etaExpand, exprArity, exprEtaExpandArity,
-- Size
coreBindsSize,
......@@ -41,10 +40,8 @@ module CoreUtils (
import GlaExts -- For `xori`
import CoreSyn
import CoreFVs ( exprFreeVars )
import PprCore ( pprCoreExpr )
import Var ( Var, isId, isTyVar )
import VarSet
import VarEnv
import Name ( hashName )
import Literal ( hashLiteral, literalType, litIsDupable )
......@@ -61,7 +58,7 @@ import NewDemand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
splitTyConApp_maybe, eqType
splitTyConApp_maybe, eqType, funResultTy, applyTy
)
import TyCon ( tyConArity )
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
......@@ -647,48 +644,11 @@ exprIsConApp_maybe expr = analyse (collectArgs expr)
%* *
%************************************************************************
@etaReduce@ trys an eta reduction at the top level of a Core Expr.
e.g. \ x y -> f x y ===> f
But we only do this if it gets rid of a whole lambda, not part.
The idea is that lambdas are often quite helpful: they indicate
head normal forms, so we don't want to chuck them away lightly.
\begin{code}
etaReduce :: CoreExpr -> CoreExpr
-- ToDo: we should really check that we don't turn a non-bottom
-- lambda into a bottom variable. Sigh
etaReduce expr@(Lam bndr body)
= check (reverse binders) body
where
(binders, body) = collectBinders expr
check [] body
| not (any (`elemVarSet` body_fvs) binders)
= body -- Success!
where
body_fvs = exprFreeVars body
check (b : bs) (App fun arg)
| (varToCoreExpr b `cheapEqExpr` arg)
= check bs fun
check _ _ = expr -- Bale out
etaReduce expr = expr -- The common case
\end{code}
\begin{code}
exprEtaExpandArity :: CoreExpr -> (Int, Bool)
exprEtaExpandArity :: CoreExpr -> Arity
-- The Int is number of value args the thing can be
-- applied to without doing much work
-- The Bool is True iff there are enough explicit value lambdas
-- at the top to make this arity apparent
-- (but ignore it when arity==0)
--
-- This is used when eta expanding
-- e ==> \xy -> e x y
--
......@@ -720,16 +680,7 @@ exprEtaExpandArity :: CoreExpr -> (Int, Bool)
-- Hence the ABot/ATop in ArityType
exprEtaExpandArity e
= go 0 e
where
go :: Int -> CoreExpr -> (Int,Bool)
go ar (Lam x e) | isId x = go (ar+1) e
| otherwise = go ar e
go ar (Note n e) | ok_note n = go ar e
go ar other = (ar + ar', ar' == 0)
where
ar' = arityDepth (arityType other)
exprEtaExpandArity e = arityDepth (arityType e)
-- A limited sort of function type
data ArityType = AFun Bool ArityType -- True <=> one-shot
......@@ -750,9 +701,10 @@ arityType :: CoreExpr -> ArityType
-- means expression can be rewritten \x_b1 -> ... \x_bn -> body
-- where bi is True <=> the lambda is one-shot
arityType (Note n e)
| ok_note n = arityType e
| otherwise = ATop
arityType (Note n e) = arityType e
-- Not needed any more: etaExpand is cleverer
-- | ok_note n = arityType e
-- | otherwise = ATop
arityType (Var v)
= mk (idArity v)
......@@ -790,6 +742,7 @@ arityType (Let b e) = case arityType e of
arityType other = ATop
{- NOT NEEDED ANY MORE: etaExpand is cleverer
ok_note InlineMe = False
ok_note other = True
-- Notice that we do not look through __inline_me__
......@@ -801,22 +754,34 @@ ok_note other = True
-- giving just
-- f = \x -> e
-- A Bad Idea
-}
\end{code}
\begin{code}
etaExpand :: Int -- Add this number of value args
etaExpand :: Arity -- Result should have this number of value args
-> [Unique]
-> CoreExpr -> Type -- Expression and its type
-> CoreExpr
-- (etaExpand n us e ty) returns an expression with
-- the same meaning as 'e', but with arity 'n'.
--
-- Given e' = etaExpand n us e ty
-- We should have
-- ty = exprType e = exprType e'
--
etaExpand n us expr ty
| manifestArity expr >= n = expr -- The no-op case
| otherwise = eta_expand n us expr ty
where
-- manifestArity sees how many leading value lambdas there are
manifestArity :: CoreExpr -> Arity
manifestArity (Lam v e) | isId v = 1 + manifestArity e
| otherwise = manifestArity e
manifestArity (Note _ e) = manifestArity e
manifestArity e = 0
-- etaExpand deals with for-alls. For example:
-- etaExpand 1 E
-- where E :: forall a. a -> a
......@@ -826,7 +791,7 @@ etaExpand :: Int -- Add this number of value args
-- It deals with coerces too, though they are now rare
-- so perhaps the extra code isn't worth it
etaExpand n us expr ty
eta_expand n us expr ty
| n == 0 &&
-- The ILX code generator requires eta expansion for type arguments
-- too, but alas the 'n' doesn't tell us how many of them there
......@@ -839,14 +804,29 @@ etaExpand n us expr ty
-- Saturated, so nothing to do
= expr
| otherwise -- An unsaturated constructor or primop; eta expand it
-- Short cut for the case where there already
-- is a lambda; no point in gratuitously adding more
eta_expand n us (Note note@(Coerce _ ty) e) _
= Note note (eta_expand n us e ty)
eta_expand n us (Note note e) ty
= Note note (eta_expand n us e ty)
eta_expand n us (Lam v body) ty
| isTyVar v
= Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
| otherwise
= Lam v (eta_expand (n-1) us body (funResultTy ty))
eta_expand n us expr ty
= case splitForAllTy_maybe ty of {
Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
; Nothing ->
case splitFunTy_maybe ty of {
Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
where
arg1 = mkSysLocal SLIT("eta") uniq arg_ty
(uniq:us2) = us
......@@ -854,7 +834,7 @@ etaExpand n us expr ty
; Nothing ->
case splitNewType_maybe ty of {
Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
Just ty' -> mkCoerce ty ty' (eta_expand n us (mkCoerce ty' ty expr) ty') ;
Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
}}}
\end{code}
......@@ -884,7 +864,7 @@ But note that (\x y z -> f x y z)
should have arity 3, regardless of f's arity.
\begin{code}
exprArity :: CoreExpr -> Int
exprArity :: CoreExpr -> Arity
exprArity e = go e
where
go (Var v) = idArity v
......
......@@ -14,7 +14,6 @@ import CoreSyn
import CoreUnfold ( couldBeSmallEnoughToInline )
import Var ( Id )
import VarEnv
import UniqFM ( ufmToList )
import Outputable
\end{code}
......
......@@ -6,7 +6,6 @@
\begin{code}
module SimplUtils (
simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinders,
tryEtaExpansion,
newId, mkLam, mkCase,
-- The continuation type
......@@ -551,6 +550,8 @@ tryEtaReduce bndrs body
go _ _ = Nothing -- Failure!
ok_fun fun = not (fun `elem` bndrs) && not (hasNoBinding fun)
-- Note the awkward "hasNoBinding" test
-- Details with exprIsTrivial
ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
\end{code}
......@@ -579,14 +580,10 @@ actually computing the expansion.
tryEtaExpansion :: OutExpr -> SimplM OutExpr
-- There is at least one runtime binder in the binders
tryEtaExpansion body
| arity_is_manifest -- Some lambdas but not enough
= returnSmpl body
| otherwise
= getUniquesSmpl `thenSmpl` \ us ->
returnSmpl (etaExpand fun_arity us body (exprType body))
where
(fun_arity, arity_is_manifest) = exprEtaExpandArity body
fun_arity = exprEtaExpandArity body
\end{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment