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

Towards better eta expansion

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 6babe48..69b244d 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -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}

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 07866a4..bb5404e 100644 (file)
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -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}

diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index 55023e7..1f59c63 100644 (file)
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -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}
 
 

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 67e57c4..9f0c1a3 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -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