From cbf5bb17365e9228f3f724b87f958982c4b66cba Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 1 Dec 2000 13:42:53 +0000
Subject: [PATCH] [project @ 2000-12-01 13:42:52 by simonpj] Towards better
 eta expansion

---
 ghc/compiler/coreSyn/CoreUtils.lhs   |   58 +++++++++++++++++++++++++++++++---
 ghc/compiler/hsSyn/HsDecls.lhs       |    2 +-
 ghc/compiler/simplCore/SimplCore.lhs |    4 +--
 ghc/compiler/simplCore/Simplify.lhs  |    2 +-
 4 files changed, 57 insertions(+), 9 deletions(-)

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 6babe48..69b244d 100644
--- 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
--- 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
--- 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
--- 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
-- 
1.7.10.4