[project @ 2004-01-12 14:36:28 by simonpj]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreUtils.lhs

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 7921b3c..8e53bbc 100644 (file)
--- 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}