Commit cbf5bb17 authored by simonpj's avatar simonpj

[project @ 2000-12-01 13:42:52 by simonpj]

Towards better eta expansion
parent 32dad922
......@@ -18,7 +18,8 @@ module CoreUtils (
idAppIsBottom, idAppIsCheap,
-- Expr transformation
etaReduceExpr, exprEtaExpandArity,
etaReduce, exprEtaExpandArity,
-- etaExpandExpr,
-- Size
coreBindsSize,
......@@ -499,7 +500,7 @@ exprIsConApp_maybe expr
%* *
%************************************************************************
@etaReduceExpr@ trys an eta reduction at the top level of a Core Expr.
@etaReduce@ trys an eta reduction at the top level of a Core Expr.
e.g. \ x y -> f x y ===> f
......@@ -508,11 +509,11 @@ 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}
etaReduceExpr :: CoreExpr -> CoreExpr
etaReduce :: CoreExpr -> CoreExpr
-- ToDo: we should really check that we don't turn a non-bottom
-- lambda into a bottom variable. Sigh
etaReduceExpr expr@(Lam bndr body)
etaReduce expr@(Lam bndr body)
= check (reverse binders) body
where
(binders, body) = collectBinders expr
......@@ -529,7 +530,7 @@ etaReduceExpr expr@(Lam bndr body)
check _ _ = expr -- Bale out
etaReduceExpr expr = expr -- The common case
etaReduce expr = expr -- The common case
\end{code}
......@@ -585,6 +586,53 @@ min_zero (x:xs) = go x xs
\end{code}
\begin{pseudocode}
etaExpand :: Int -- Add this number of value args
-> UniquSupply
-> CoreExpr -> Type -- Expression and its type
-> CoreEpxr
-- Given e' = etaExpand n us e ty
-- We should have
-- ty = exprType e = exprType e'
--
-- etaExpand deals with for-alls and coerces. For example:
-- etaExpand 1 E
-- where E :: forall a. T
-- newtype T = MkT (A -> B)
--
-- would return
-- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
-- (case x of { I# x -> /\ a -> coerce T E)
etaExpand n us expr ty
| n == 0 -- Saturated, so nothing to do
= expr
| otherwise -- An unsaturated constructor or primop; eta expand it
= case splitForAllTy_maybe ty of {
Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
Nothing ->
case splitFunTy_maybe ty of {
Just (arg_ty, res_ty) -> Lam arg' (etaExpand (n-1) us2 (App expr (Var arg')) res_ty)
where
arg' = mkSysLocal SLIT("eta") uniq arg_ty
(us1, us2) = splitUnqiSupply us
uniq = uniqFromSupply us1
Nothing ->
case splitNewType_maybe ty of {
Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty')
Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
}}}
\end{pseudocode}
%************************************************************************
%* *
\subsection{Equality}
......
......@@ -3,7 +3,7 @@
%
\section[HsDecls]{Abstract syntax: global declarations}
Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@,
Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
@InstDecl@, @DefaultDecl@ and @ForeignDecl@.
\begin{code}
......
......@@ -25,7 +25,7 @@ import Module ( moduleEnvElts )
import CoreUnfold
import PprCore ( pprCoreBindings, pprIdCoreRule, pprCoreExpr )
import OccurAnal ( occurAnalyseBinds )
import CoreUtils ( etaReduceExpr, coreBindsSize )
import CoreUtils ( etaReduce, coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
import SimplUtils ( simplBinders )
import SimplMonad
......@@ -297,7 +297,7 @@ simpl_arg e
-- Otherwise we don't match when given an argument like
-- (\a. h a a)
= simplExpr e `thenSmpl` \ e' ->
returnSmpl (etaReduceExpr e')
returnSmpl (etaReduce e')
\end{code}
......
......@@ -346,7 +346,7 @@ completeLam rev_bndrs body cont
Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont
where
-- We don't use CoreUtils.etaReduceExpr, because we can be more
-- We don't use CoreUtils.etaReduce, because we can be more
-- efficient here: (a) we already have the binders, (b) we can do
-- the triviality test before computing the free vars
try_eta body | not opt_SimplDoEtaReduction = Nothing
......
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