X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=8e53bbcec12e5033293ad0ff89fd26cc431a6055;hb=20e1c6cc426dcc864c7fc5710b1b5aa25453061c;hp=7921b3cfcfccdee16742102e7baff44b63d6765f;hpb=2129fa6fc4afd7f7b0c767f8c0c14b9ab5508ec2;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 7921b3c..8e53bbc 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -6,16 +6,16 @@
 \begin{code}
 module CoreUtils (
 	-- Construction
-	mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
+	mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
 	bindNonRec, needsCaseBinding,
 	mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
 	-- Taking expressions apart
-	findDefault, findAlt, hasDefault,
+	findDefault, findAlt,
 
 	-- Properties of expressions
-	exprType, coreAltsType, 
-	exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, 
+	exprType,
+	exprIsDupable, exprIsTrivial, exprIsCheap, 
 	exprIsValue,exprOkForSpeculation, exprIsBig, 
 	exprIsConApp_maybe, 
 	rhsIsStatic,
@@ -47,7 +47,7 @@ import Name		( hashName, isDllName )
 import Literal		( hashLiteral, literalType, litIsDupable, 
 			  litIsTrivial, isZeroLit )
 import DataCon		( DataCon, dataConRepArity, dataConArgTys,
-			  isExistentialDataCon, dataConTyCon, dataConName )
+			  isExistentialDataCon, dataConTyCon )
 import PrimOp		( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
 import Id		( Id, idType, globalIdDetails, idNewStrictness, 
 			  mkWildId, idArity, idName, idUnfolding, idInfo,
@@ -59,7 +59,7 @@ import NewDemand	( appIsBottom )
 import Type		( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
 			  splitFunTy,
 			  applyTys, isUnLiftedType, seqType, mkTyVarTy,
-			  splitForAllTy_maybe, isForAllTy, splitNewType_maybe, 
+			  splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, 
 			  splitTyConApp_maybe, eqType, funResultTy, applyTy,
 			  funResultTy, applyTy
 			)
@@ -154,11 +154,13 @@ applyTypeToArgs e op_ty (other_arg : args)
 mkNote removes redundant coercions, and SCCs where possible
 
 \begin{code}
+#ifdef UNUSED
 mkNote :: Note -> CoreExpr -> CoreExpr
 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
 mkNote (SCC cc)	expr		   = mkSCC cc expr
 mkNote InlineMe expr		   = mkInlineMe expr
 mkNote note     expr		   = Note note expr
+#endif
 
 -- Slide InlineCall in around the function
 --	No longer necessary I think (SLPJ Apr 99)
@@ -276,10 +278,6 @@ The default alternative must be first, if it exists at all.
 This makes it easy to find, though it makes matching marginally harder.
 
 \begin{code}
-hasDefault :: [CoreAlt] -> Bool
-hasDefault ((DEFAULT,_,_) : alts) = True
-hasDefault _			  = False
-
 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
 findDefault alts			= 		      (alts, Nothing)
@@ -795,6 +793,11 @@ arityType (App f a)  	   = case arityType f of
 							   
 	-- Case/Let; keep arity if either the expression is cheap
 	-- or it's a 1-shot lambda
+	-- The former is not really right for Haskell
+	--	f x = case x of { (a,b) -> \y. e }
+	--  ===>
+	--	f x y = case x of { (a,b) -> e }
+	-- The difference is observable using 'seq'
 arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
 				  xs@(AFun one_shot _) | one_shot -> xs
 				  xs | exprIsCheap scrut	  -> xs
@@ -932,15 +935,17 @@ eta_expand n us expr ty
 	; Nothing ->
 
 		-- Given this:
-		-- 	newtype T = MkT (Int -> Int)
+		-- 	newtype T = MkT ([T] -> Int)
 		-- Consider eta-expanding this
 		--  	eta_expand 1 e T
 		-- We want to get
-		--	coerce T (\x::Int -> (coerce (Int->Int) e) x)
+		--	coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
+		-- Only try this for recursive newtypes; the non-recursive kind
+		-- are transparent anyway
 
-    	case splitNewType_maybe ty of {
+    	case splitRecNewType_maybe ty of {
  	  Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
- 	  Nothing  -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
+ 	  Nothing  -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
     	}}}
 \end{code}