[project @ 2002-03-04 17:01:26 by simonmar]

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

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index e513548..ab99d49 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -7,11 +7,11 @@
 module CoreUtils (
        -- Construction
        mkNote, mkInlineMe, mkSCC, mkCoerce,
 module CoreUtils (
        -- Construction
        mkNote, mkInlineMe, mkSCC, mkCoerce,

-       bindNonRec, mkIfThenElse, mkAltExpr,
-        mkPiType,
+       bindNonRec, needsCaseBinding,
+       mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,

 
        -- Taking expressions apart
 
        -- Taking expressions apart

-       findDefault, findAlt,
+       findDefault, findAlt, hasDefault,

 
        -- Properties of expressions
        exprType, coreAltsType, 
 
        -- Properties of expressions
        exprType, coreAltsType, 

@@ -19,11 +19,11 @@ module CoreUtils (
        exprIsValue,exprOkForSpeculation, exprIsBig, 
        exprIsConApp_maybe, exprIsAtom,
        idAppIsBottom, idAppIsCheap,
        exprIsValue,exprOkForSpeculation, exprIsBig, 
        exprIsConApp_maybe, exprIsAtom,
        idAppIsBottom, idAppIsCheap,

-       exprArity, isRuntimeVar, isRuntimeArg, 

 
 

-       -- Expr transformation
-       etaReduce, etaExpand,
-       exprArity, exprEtaExpandArity, 
+
+       -- Arity and eta expansion
+       manifestArity, exprArity, 
+       exprEtaExpandArity, etaExpand, 

 
        -- Size
        coreBindsSize,
 
        -- Size
        coreBindsSize,

@@ -32,7 +32,7 @@ module CoreUtils (
        hashExpr,
 
        -- Equality
        hashExpr,
 
        -- Equality

-       cheapEqExpr, eqExpr, applyTypeToArgs
+       cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -41,33 +41,34 @@ module CoreUtils (
 import GlaExts         -- For `xori` 
 
 import CoreSyn
 import GlaExts         -- For `xori` 
 
 import CoreSyn

-import CoreFVs         ( exprFreeVars )

 import PprCore         ( pprCoreExpr )
 import Var             ( Var, isId, isTyVar )
 import PprCore         ( pprCoreExpr )
 import Var             ( Var, isId, isTyVar )

-import VarSet

 import VarEnv
 import Name            ( hashName )
 import VarEnv
 import Name            ( hashName )

-import Literal         ( hashLiteral, literalType, litIsDupable )
-import DataCon         ( DataCon, dataConRepArity )
-import PrimOp          ( primOpOkForSpeculation, primOpIsCheap )
-import Id              ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo, 
+import Literal         ( hashLiteral, literalType, litIsDupable, isZeroLit )
+import DataCon         ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon )
+import PrimOp          ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
+import Id              ( Id, idType, globalIdDetails, idNewStrictness, 

                          mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
                          mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,

-                         isDataConId_maybe, mkSysLocal, hasNoBinding
+                         isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId

                        )
                        )

-import IdInfo          ( LBVarInfo(..),  
-                         GlobalIdDetails(..),
+import IdInfo          ( GlobalIdDetails(..),

                          megaSeqIdInfo )
                          megaSeqIdInfo )

-import Demand          ( appIsBottom )
-import Type            ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, 
-                         applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
-                         splitForAllTy_maybe, splitNewType_maybe, isForAllTy
+import NewDemand       ( appIsBottom )
+import Type            ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
+                         applyTys, isUnLiftedType, seqType, mkTyVarTy,
+                         splitForAllTy_maybe, isForAllTy, splitNewType_maybe, 
+                         splitTyConApp_maybe, eqType, funResultTy, applyTy,
+                         funResultTy, applyTy

                        )
                        )

+import TyCon           ( tyConArity )

 import TysWiredIn      ( boolTy, trueDataCon, falseDataCon )
 import CostCentre      ( CostCentre )
 import TysWiredIn      ( boolTy, trueDataCon, falseDataCon )
 import CostCentre      ( CostCentre )

-import UniqSupply      ( UniqSupply, splitUniqSupply, uniqFromSupply )
+import BasicTypes      ( Arity )
+import Unique          ( Unique )

 import Outputable
 import TysPrim         ( alphaTy )     -- Debugging only
 import Outputable
 import TysPrim         ( alphaTy )     -- Debugging only

-import CmdLineOpts     ( opt_KeepStgTypes )
+import Util             ( equalLength, lengthAtLeast )

 \end{code}
 
 
 \end{code}
 
 

@@ -103,26 +104,35 @@ lbvarinfo field to figure out the right annotation for the arrove in
 case of a term variable.
 
 \begin{code}
 case of a term variable.
 
 \begin{code}

-mkPiType :: Var -> Type -> Type                -- The more polymorphic version doesn't work...
-mkPiType v ty | isId v    = (case idLBVarInfo v of
-                               LBVarInfo u -> mkUTy u
-                               otherwise   -> id) $
-                            mkFunTy (idType v) ty
-             | isTyVar v = mkForAllTy v ty
+mkPiType  :: Var   -> Type -> Type     -- The more polymorphic version
+mkPiTypes :: [Var] -> Type -> Type     --    doesn't work...
+
+mkPiTypes vs ty = foldr mkPiType ty vs
+
+mkPiType v ty
+   | isId v    = mkFunTy (idType v) ty
+   | otherwise = mkForAllTy v ty

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

--- The first argument is just for debugging
+applyTypeToArg :: Type -> CoreExpr -> Type
+applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
+applyTypeToArg fun_ty other_arg     = funResultTy fun_ty
+

 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type

+-- A more efficient version of applyTypeToArg 
+-- when we have several args
+-- The first argument is just for debugging

 applyTypeToArgs e op_ty [] = op_ty
 
 applyTypeToArgs e op_ty (Type ty : args)
   =    -- Accumulate type arguments so we can instantiate all at once
 applyTypeToArgs e op_ty [] = op_ty
 
 applyTypeToArgs e op_ty (Type ty : args)
   =    -- Accumulate type arguments so we can instantiate all at once

-    applyTypeToArgs e (applyTys op_ty tys) rest_args
+    go [ty] args

   where
   where

-    (tys, rest_args)        = go [ty] args
-    go tys (Type ty : args) = go (ty:tys) args
-    go tys rest_args       = (reverse tys, rest_args)
+    go rev_tys (Type ty : args) = go (ty:rev_tys) args
+    go rev_tys rest_args        = applyTypeToArgs e op_ty' rest_args
+                               where
+                                 op_ty' = applyTys op_ty (reverse rev_tys)

 
 applyTypeToArgs e op_ty (other_arg : args)
   = case (splitFunTy_maybe op_ty) of
 
 applyTypeToArgs e op_ty (other_arg : args)
   = case (splitFunTy_maybe op_ty) of

@@ -186,13 +196,13 @@ mkInlineMe e         = Note InlineMe e
 mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
 
 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
 mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
 
 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)

-  = ASSERT( from_ty == to_ty2 )
+  = ASSERT( from_ty `eqType` to_ty2 )

     mkCoerce to_ty from_ty2 expr
 
 mkCoerce to_ty from_ty expr
     mkCoerce to_ty from_ty2 expr
 
 mkCoerce to_ty from_ty expr

-  | to_ty == from_ty = expr
-  | otherwise       = ASSERT( from_ty == exprType expr )
-                      Note (Coerce to_ty from_ty) expr
+  | to_ty `eqType` from_ty = expr
+  | otherwise             = ASSERT( from_ty `eqType` exprType expr )
+                            Note (Coerce to_ty from_ty) expr

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -225,8 +235,13 @@ bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 -- that give Core Lint a heart attack.  Actually the simplifier
 -- deals with them perfectly well.
 bindNonRec bndr rhs body 
 -- that give Core Lint a heart attack.  Actually the simplifier
 -- deals with them perfectly well.
 bindNonRec bndr rhs body 

-  | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
-  | otherwise                   = Let (NonRec bndr rhs) body
+  | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
+  | otherwise                         = Let (NonRec bndr rhs) body
+
+needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
+       -- Make a case expression instead of a let
+       -- These can arise either from the desugarer,
+       -- or from beta reductions: (\x.e) (x +# y)

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -252,25 +267,31 @@ mkIfThenElse guard then_expr else_expr
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

+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}
 
 \begin{code}

+hasDefault :: [CoreAlt] -> Bool
+hasDefault ((DEFAULT,_,_) : alts) = True
+hasDefault _                     = False
+

 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)

-findDefault []                         = ([], Nothing)
-findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args ) 
-                                         ([], Just rhs)
-findDefault (alt : alts)               = case findDefault alts of 
-                                           (alts', deflt) -> (alt : alts', deflt)
+findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
+findDefault alts                       =                     (alts, Nothing)

 
 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
 findAlt con alts
 
 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
 findAlt con alts

-  = go alts
+  = case alts of
+       (deflt@(DEFAULT,_,_):alts) -> go alts deflt
+       other                      -> go alts panic_deflt
+

   where
   where

-    go []          = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
-    go (alt : alts) | matches alt = alt
-                   | otherwise   = go alts
+    panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))

 
 

-    matches (DEFAULT, _, _) = True
-    matches (con1, _, _)    = con == con1
+    go []                     deflt               = deflt
+    go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
+                                    | otherwise   = ASSERT( not (con1 == DEFAULT) )
+                                                    go alts deflt

 \end{code}
 
 
 \end{code}
 
 

@@ -288,26 +309,25 @@ findAlt con alts
 @exprIsBottom@ is true of expressions that are guaranteed to diverge
 
 
 @exprIsBottom@ is true of expressions that are guaranteed to diverge
 
 

+There used to be a gruesome test for (hasNoBinding v) in the
+Var case:
+       exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
+The idea here is that a constructor worker, like $wJust, is
+really short for (\x -> $wJust x), becuase $wJust has no binding.
+So it should be treated like a lambda.  Ditto unsaturated primops.
+But now constructor workers are not "have-no-binding" Ids.  And
+completely un-applied primops and foreign-call Ids are sufficiently
+rare that I plan to allow them to be duplicated and put up with
+saturating them.
+

 \begin{code}
 \begin{code}

-exprIsTrivial (Var v)
-  | hasNoBinding v                    = idArity v == 0
-       -- WAS: | Just op <- isPrimOpId_maybe v      = primOpIsDupable op
-       -- The idea here is that a constructor worker, like $wJust, is
-       -- really short for (\x -> $wJust x), becuase $wJust has no binding.
-       -- So it should be treated like a lambda.
-       -- Ditto unsaturated primops.
-       -- This came up when dealing with eta expansion/reduction for
-       --      x = $wJust
-       -- Here we want to eta-expand.  This looks like an optimisation,
-       -- but it's important (albeit tiresome) that CoreSat doesn't increase 
-       -- anything's arity
-  | otherwise                          = True
-exprIsTrivial (Type _)                = True
-exprIsTrivial (Lit lit)               = True
-exprIsTrivial (App e arg)             = not (isRuntimeArg arg) && exprIsTrivial e
-exprIsTrivial (Note _ e)              = exprIsTrivial e
-exprIsTrivial (Lam b body)             = not (isRuntimeVar b) && exprIsTrivial body
-exprIsTrivial other                   = False
+exprIsTrivial (Var v)     = True       -- See notes above
+exprIsTrivial (Type _)    = True
+exprIsTrivial (Lit lit)    = True
+exprIsTrivial (App e arg)  = not (isRuntimeArg arg) && exprIsTrivial e
+exprIsTrivial (Note _ e)   = exprIsTrivial e
+exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
+exprIsTrivial other       = False

 
 exprIsAtom :: CoreExpr -> Bool
 -- Used to decide whether to let-binding an STG argument
 
 exprIsAtom :: CoreExpr -> Bool
 -- Used to decide whether to let-binding an STG argument

@@ -413,7 +433,7 @@ exprIsCheap other_expr
        
     go (App f a) n_args args_cheap 
        | not (isRuntimeArg a) = go f n_args      args_cheap
        
     go (App f a) n_args args_cheap 
        | not (isRuntimeArg a) = go f n_args      args_cheap

-       | otherwise   = go f (n_args + 1) (exprIsCheap a && args_cheap)
+       | otherwise            = go f (n_args + 1) (exprIsCheap a && args_cheap)

 
     go other   n_args args_cheap = False
 
 
     go other   n_args args_cheap = False
 

@@ -464,28 +484,50 @@ side effects, and can't diverge or raise an exception.
 \begin{code}
 exprOkForSpeculation :: CoreExpr -> Bool
 exprOkForSpeculation (Lit _)    = True
 \begin{code}
 exprOkForSpeculation :: CoreExpr -> Bool
 exprOkForSpeculation (Lit _)    = True

+exprOkForSpeculation (Type _)   = True

 exprOkForSpeculation (Var v)    = isUnLiftedType (idType v)
 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
 exprOkForSpeculation other_expr
 exprOkForSpeculation (Var v)    = isUnLiftedType (idType v)
 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
 exprOkForSpeculation other_expr

-  = go other_expr 0 True
+  = case collectArgs other_expr of
+       (Var f, args) -> spec_ok (globalIdDetails f) args
+       other         -> False
+ 

   where
   where

-    go (Var f) n_args args_ok 
-      = case globalIdDetails f of
-         DataConId _ -> True   -- The strictness of the constructor has already
-                               -- been expressed by its "wrapper", so we don't need
-                               -- to take the arguments into account
-
-         PrimOpId op -> primOpOkForSpeculation op && args_ok
+    spec_ok (DataConId _) args
+      = True   -- The strictness of the constructor has already
+               -- been expressed by its "wrapper", so we don't need
+               -- to take the arguments into account
+
+    spec_ok (PrimOpId op) args
+      | isDivOp op,            -- Special case for dividing operations that fail
+       [arg1, Lit lit] <- args -- only if the divisor is zero
+      = not (isZeroLit lit) && exprOkForSpeculation arg1
+               -- Often there is a literal divisor, and this 
+               -- can get rid of a thunk in an inner looop
+
+      | otherwise
+      = primOpOkForSpeculation op && 
+       all exprOkForSpeculation args

                                -- A bit conservative: we don't really need
                                -- to care about lazy arguments, but this is easy
 
                                -- A bit conservative: we don't really need
                                -- to care about lazy arguments, but this is easy
 

-         other -> False
-       
-    go (App f a) n_args args_ok 
-       | not (isRuntimeArg a) = go f n_args      args_ok
-       | otherwise   = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
-
-    go other n_args args_ok = False
+    spec_ok other args = False
+
+isDivOp :: PrimOp -> Bool
+-- True of dyadic operators that can fail 
+-- only if the second arg is zero
+-- This function probably belongs in PrimOp, or even in 
+-- an automagically generated file.. but it's such a 
+-- special case I thought I'd leave it here for now.
+isDivOp IntQuotOp       = True
+isDivOp IntRemOp        = True
+isDivOp WordQuotOp      = True
+isDivOp WordRemOp       = True
+isDivOp IntegerQuotRemOp = True
+isDivOp IntegerDivModOp  = True
+isDivOp FloatDivOp       = True
+isDivOp DoubleDivOp      = True
+isDivOp other           = False

 \end{code}
 
 
 \end{code}
 
 

@@ -503,11 +545,13 @@ exprIsBottom e = go 0 e
                 go n (Lam _ _)    = False
 
 idAppIsBottom :: Id -> Int -> Bool
                 go n (Lam _ _)    = False
 
 idAppIsBottom :: Id -> Int -> Bool

-idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
+idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args

 \end{code}
 
 @exprIsValue@ returns true for expressions that are certainly *already* 
 \end{code}
 
 @exprIsValue@ returns true for expressions that are certainly *already* 

-evaluated to WHNF.  This is used to decide wether it's ok to change
+evaluated to *head* normal form.  This is used to decide whether it's ok 
+to change
+

        case x of _ -> e   ===>   e
 
 and to decide whether it's safe to discard a `seq`
        case x of _ -> e   ===>   e
 
 and to decide whether it's safe to discard a `seq`

@@ -515,12 +559,13 @@ and to decide whether it's safe to discard a `seq`
 So, it does *not* treat variables as evaluated, unless they say they are.
 
 But it *does* treat partial applications and constructor applications
 So, it does *not* treat variables as evaluated, unless they say they are.
 
 But it *does* treat partial applications and constructor applications

-as values, even if their arguments are non-trivial; 
+as values, even if their arguments are non-trivial, provided the argument
+type is lifted; 

        e.g.  (:) (f x) (map f xs)      is a value
              map (...redex...)         is a value
 Because `seq` on such things completes immediately
 
        e.g.  (:) (f x) (map f xs)      is a value
              map (...redex...)         is a value
 Because `seq` on such things completes immediately
 

-A possible worry: constructors with unboxed args:
+For unlifted argument types, we have to be careful:

                C (f x :: Int#)
 Suppose (f x) diverges; then C (f x) is not a value.  True, but
 this form is illegal (see the invariants in CoreSyn).  Args of unboxed
                C (f x :: Int#)
 Suppose (f x) diverges; then C (f x) is not a value.  True, but
 this form is illegal (see the invariants in CoreSyn).  Args of unboxed

@@ -533,56 +578,83 @@ exprIsValue (Type ty)       = True        -- Types are honorary Values; we don't mind
 exprIsValue (Lit l)      = True
 exprIsValue (Lam b e)            = isRuntimeVar b || exprIsValue e
 exprIsValue (Note _ e)           = exprIsValue e
 exprIsValue (Lit l)      = True
 exprIsValue (Lam b e)            = isRuntimeVar b || exprIsValue e
 exprIsValue (Note _ e)           = exprIsValue e

-exprIsValue other_expr
-  = go other_expr 0
-  where
-    go (Var f) n_args = idAppIsValue f n_args
-       
-    go (App f a) n_args
-       | not (isRuntimeArg a) = go f n_args
-       | otherwise   = go f (n_args + 1) 
-
-    go (Note _ f) n_args = go f n_args
-
-    go other n_args = False
-
-idAppIsValue :: Id -> Int -> Bool
-idAppIsValue id n_val_args 
-  = case globalIdDetails id of
-       DataConId _ -> True
-       PrimOpId _  -> n_val_args < idArity id
-       other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
-             | otherwise       -> n_val_args < idArity id
+exprIsValue (Var v)      = idArity v > 0 || isEvaldUnfolding (idUnfolding v)
+       -- The idArity case catches data cons and primops that 
+       -- don't have unfoldings

        -- A worry: what if an Id's unfolding is just itself: 
        -- then we could get an infinite loop...
        -- A worry: what if an Id's unfolding is just itself: 
        -- then we could get an infinite loop...

-\end{code}
-
-@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
-i.e. if type applications are actual lambdas because types are kept around
-at runtime.
-
-\begin{code}
-isRuntimeVar :: Var -> Bool
-isRuntimeVar v = opt_KeepStgTypes || isId v
-isRuntimeArg :: CoreExpr -> Bool
-isRuntimeArg v = opt_KeepStgTypes || isTypeArg v
+exprIsValue other_expr
+  | (Var fun, args) <- collectArgs other_expr,
+    isDataConId fun || valArgCount args < idArity fun
+  = check (idType fun) args
+  | otherwise
+  = False
+  where
+       -- 'check' checks that unlifted-type args are in
+       -- fact guaranteed non-divergent
+    check fun_ty []             = True
+    check fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
+                                    Just (_, ty) -> check ty args
+    check fun_ty (arg : args)
+       | isUnLiftedType arg_ty = exprOkForSpeculation arg
+       | otherwise             = check res_ty args
+       where
+         (arg_ty, res_ty) = splitFunTy fun_ty

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-
-

 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])

-exprIsConApp_maybe (Note InlineMe expr) = exprIsConApp_maybe expr
+exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
+  =    -- Maybe this is over the top, but here we try to turn
+       --      coerce (S,T) ( x, y )
+       -- effectively into 
+       --      ( coerce S x, coerce T y )
+       -- This happens in anger in PrelArrExts which has a coerce
+       --      case coerce memcpy a b of
+       --        (# r, s #) -> ...
+       -- where the memcpy is in the IO monad, but the call is in
+       -- the (ST s) monad
+    case exprIsConApp_maybe expr of {
+       Nothing           -> Nothing ;
+       Just (dc, args)   -> 
+  
+    case splitTyConApp_maybe to_ty of {
+       Nothing -> Nothing ;
+       Just (tc, tc_arg_tys) | tc /= dataConTyCon dc   -> Nothing
+                             | isExistentialDataCon dc -> Nothing
+                             | otherwise               ->
+               -- Type constructor must match
+               -- We knock out existentials to keep matters simple(r)
+    let
+       arity            = tyConArity tc
+       val_args         = drop arity args
+       to_arg_tys       = dataConArgTys dc tc_arg_tys
+       mk_coerce ty arg = mkCoerce ty (exprType arg) arg
+       new_val_args     = zipWith mk_coerce to_arg_tys val_args
+    in
+    ASSERT( all isTypeArg (take arity args) )
+    ASSERT( equalLength val_args to_arg_tys )
+    Just (dc, map Type tc_arg_tys ++ new_val_args)
+    }}
+
+exprIsConApp_maybe (Note _ expr)
+  = exprIsConApp_maybe expr

     -- We ignore InlineMe notes in case we have
     -- x = __inline_me__ (a,b)
     -- All part of making sure that INLINE pragmas never hurt
     -- Marcin tripped on this one when making dictionaries more inlinable
     -- We ignore InlineMe notes in case we have
     -- x = __inline_me__ (a,b)
     -- All part of making sure that INLINE pragmas never hurt
     -- Marcin tripped on this one when making dictionaries more inlinable

+    --
+    -- In fact, we ignore all notes.  For example,
+    --         case _scc_ "foo" (C a b) of
+    --                 C a b -> e
+    -- should be optimised away, but it will be only if we look
+    -- through the SCC note.

 
 exprIsConApp_maybe expr = analyse (collectArgs expr)
   where
     analyse (Var fun, args)
        | Just con <- isDataConId_maybe fun,
 
 exprIsConApp_maybe expr = analyse (collectArgs expr)
   where
     analyse (Var fun, args)
        | Just con <- isDataConId_maybe fun,

-         length args >= dataConRepArity con
+         args `lengthAtLeast` dataConRepArity con

                -- Might be > because the arity excludes type args
        = Just (con,args)
 
                -- Might be > because the arity excludes type args
        = Just (con,args)
 

@@ -604,48 +676,11 @@ exprIsConApp_maybe expr = analyse (collectArgs expr)
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-@etaReduce@ trys an eta reduction at the top level of a Core Expr.
-
-e.g.   \ x y -> f x y  ===>  f
-
-But we only do this if it gets rid of a whole lambda, not part.
-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}
-etaReduce :: CoreExpr -> CoreExpr
-               -- ToDo: we should really check that we don't turn a non-bottom
-               -- lambda into a bottom variable.  Sigh
-
-etaReduce expr@(Lam bndr body)
-  = check (reverse binders) body
-  where
-    (binders, body) = collectBinders expr
-
-    check [] body
-       | not (any (`elemVarSet` body_fvs) binders)
-       = body                  -- Success!
-       where
-         body_fvs = exprFreeVars body
-
-    check (b : bs) (App fun arg)
-       |  (varToCoreExpr b `cheapEqExpr` arg)
-       = check bs fun
-
-    check _ _ = expr   -- Bale out
-
-etaReduce expr = expr          -- The common case
-\end{code}
-       
-

 \begin{code}
 \begin{code}

-exprEtaExpandArity :: CoreExpr -> (Int, Bool)  
+exprEtaExpandArity :: CoreExpr -> Arity

 -- The Int is number of value args the thing can be 
 --     applied to without doing much work
 -- The Int is number of value args the thing can be 
 --     applied to without doing much work

--- The Bool is True iff there are enough explicit value lambdas
---     at the top to make this arity apparent
---     (but ignore it when arity==0)
-
+--

 -- This is used when eta expanding
 --     e  ==>  \xy -> e x y
 --
 -- This is used when eta expanding
 --     e  ==>  \xy -> e x y
 --

@@ -653,106 +688,142 @@ exprEtaExpandArity :: CoreExpr -> (Int, Bool)
 --     case x of p -> \s -> ...
 -- because for I/O ish things we really want to get that \s to the top.
 -- We are prepared to evaluate x each time round the loop in order to get that
 --     case x of p -> \s -> ...
 -- because for I/O ish things we really want to get that \s to the top.
 -- We are prepared to evaluate x each time round the loop in order to get that

---
--- Consider    let x = expensive in \y z -> E
+
+-- It's all a bit more subtle than it looks.  Consider one-shot lambdas
+--             let x = expensive in \y z -> E

 -- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
 -- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda

--- 
--- Hence the list of Bools returned by go1
---     NB: this is particularly important/useful for IO state 
---     transformers, where we often get
---             let x = E in \ s -> ...
---     and the \s is a real-world state token abstraction.  Such 
---     abstractions are almost invariably 1-shot, so we want to
---     pull the \s out, past the let x=E.  
---     The hack is in Id.isOneShotLambda
-
-exprEtaExpandArity e
-  = go 0 e
-  where
-    go :: Int -> CoreExpr -> (Int,Bool)
-    go ar (Lam x e)  | isId x          = go (ar+1) e
-                    | otherwise        = go ar e
-    go ar (Note n e) | ok_note n       = go ar e
-    go ar other                        = (ar + ar', ar' == 0)
-                                       where
-                                         ar' = length (go1 other)
-
-    go1 :: CoreExpr -> [Bool]
+-- Hence the ArityType returned by arityType
+
+-- NB: this is particularly important/useful for IO state 
+-- transformers, where we often get
+--     let x = E in \ s -> ...
+-- and the \s is a real-world state token abstraction.  Such 
+-- abstractions are almost invariably 1-shot, so we want to
+-- pull the \s out, past the let x=E.  
+-- The hack is in Id.isOneShotLambda
+--
+-- Consider also 
+--     f = \x -> error "foo"
+-- Here, arity 1 is fine.  But if it is
+--     f = \x -> case e of 
+--                     True  -> error "foo"
+--                     False -> \y -> x+y
+-- then we want to get arity 2.
+-- Hence the ABot/ATop in ArityType
+
+
+exprEtaExpandArity e = arityDepth (arityType e)
+
+-- A limited sort of function type
+data ArityType = AFun Bool ArityType   -- True <=> one-shot
+              | ATop                   -- Know nothing
+              | ABot                   -- Diverges
+
+arityDepth :: ArityType -> Arity
+arityDepth (AFun _ ty) = 1 + arityDepth ty
+arityDepth ty         = 0
+
+andArityType ABot          at2           = at2
+andArityType ATop          at2           = ATop
+andArityType (AFun t1 at1)  (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
+andArityType at1           at2           = andArityType at2 at1
+
+arityType :: CoreExpr -> ArityType

        -- (go1 e) = [b1,..,bn]
        -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
        -- where bi is True <=> the lambda is one-shot
 
        -- (go1 e) = [b1,..,bn]
        -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
        -- where bi is True <=> the lambda is one-shot
 

-    go1 (Note n e) | ok_note n = go1 e
-    go1 (Var v)                        = replicate (idArity v) False   -- When the type of the Id
-                                                               -- encodes one-shot-ness, use
-                                                               -- the idinfo here
+arityType (Note n e) = arityType e
+--     Not needed any more: etaExpand is cleverer
+--  | ok_note n = arityType e
+--  | otherwise = ATop
+
+arityType (Var v) 
+  = mk (idArity v)
+  where
+    mk :: Arity -> ArityType
+    mk 0 | isBottomingId v  = ABot
+         | otherwise       = ATop
+    mk n                   = AFun False (mk (n-1))
+
+                       -- When the type of the Id encodes one-shot-ness,
+                       -- use the idinfo here

 
        -- Lambdas; increase arity
 
        -- Lambdas; increase arity

-    go1 (Lam x e)  | isId x     = isOneShotLambda x : go1 e
-                  | otherwise  = go1 e
+arityType (Lam x e) | isId x    = AFun (isOneShotLambda x) (arityType e)
+                   | otherwise = arityType e

 
        -- Applications; decrease arity
 
        -- Applications; decrease arity

-    go1 (App f (Type _))       = go1 f
-    go1 (App f a)              = case go1 f of
-                                   (one_shot : xs) | one_shot || exprIsCheap a -> xs
-                                   other                                       -> []
+arityType (App f (Type _)) = arityType f
+arityType (App f a)       = case arityType f of
+                               AFun one_shot xs | one_shot      -> xs
+                                                | exprIsCheap a -> xs
+                               other                            -> ATop

                                                           
        -- Case/Let; keep arity if either the expression is cheap
        -- or it's a 1-shot lambda
                                                           
        -- Case/Let; keep arity if either the expression is cheap
        -- or it's a 1-shot lambda

-    go1 (Case scrut _ alts) = case foldr1 (zipWith (&&)) [go1 rhs | (_,_,rhs) <- alts] of
-                               xs@(one_shot : _) | one_shot || exprIsCheap scrut -> xs
-                               other                                             -> []
-    go1 (Let b e) = case go1 e of
-                     xs@(one_shot : _) | one_shot || all exprIsCheap (rhssOfBind b) -> xs
-                     other                                                          -> []
-
-    go1 other = []
-    
-    ok_note (Coerce _ _) = True
-    ok_note InlineCall   = True
-    ok_note other        = False
-           -- Notice that we do not look through __inline_me__
-           -- This may seem surprising, but consider
-           --  f = _inline_me (\x -> e)
-           -- We DO NOT want to eta expand this to
-           --  f = \x -> (_inline_me (\x -> e)) x
-           -- because the _inline_me gets dropped now it is applied, 
-           -- giving just
-           --  f = \x -> e
-           -- A Bad Idea
-
-min_zero :: [Int] -> Int       -- Find the minimum, but zero is the smallest
-min_zero (x:xs) = go x xs
-               where
-                 go 0   xs                 = 0         -- Nothing beats zero
-                 go min []                 = min
-                 go min (x:xs) | x < min   = go x xs
-                               | otherwise = go min xs 
-
+arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
+                                 xs@(AFun one_shot _) | one_shot -> xs
+                                 xs | exprIsCheap scrut          -> xs
+                                    | otherwise                  -> ATop
+
+arityType (Let b e) = case arityType e of
+                       xs@(AFun one_shot _) | one_shot                       -> xs
+                       xs                   | all exprIsCheap (rhssOfBind b) -> xs
+                                            | otherwise                      -> ATop
+
+arityType other = ATop
+
+{- NOT NEEDED ANY MORE: etaExpand is cleverer
+ok_note InlineMe = False
+ok_note other    = True
+    -- Notice that we do not look through __inline_me__
+    -- This may seem surprising, but consider
+    --         f = _inline_me (\x -> e)
+    -- We DO NOT want to eta expand this to
+    --         f = \x -> (_inline_me (\x -> e)) x
+    -- because the _inline_me gets dropped now it is applied, 
+    -- giving just
+    --         f = \x -> e
+    -- A Bad Idea
+-}

 \end{code}
 
 
 \begin{code}
 \end{code}
 
 
 \begin{code}

-etaExpand :: Int               -- Add this number of value args
-         -> UniqSupply
+etaExpand :: Arity             -- Result should have this number of value args
+         -> [Unique]

          -> CoreExpr -> Type   -- Expression and its type
          -> CoreExpr
 -- (etaExpand n us e ty) returns an expression with 
 -- the same meaning as 'e', but with arity 'n'.  
          -> CoreExpr -> Type   -- Expression and its type
          -> CoreExpr
 -- (etaExpand n us e ty) returns an expression with 
 -- the same meaning as 'e', but with arity 'n'.  

-
+--

 -- Given e' = etaExpand n us e ty
 -- We should have
 --     ty = exprType e = exprType e'
 -- 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 n us expr ty
+  | manifestArity expr >= n = expr             -- The no-op case
+  | otherwise              = eta_expand n us expr ty
+  where
+
+-- manifestArity sees how many leading value lambdas there are
+manifestArity :: CoreExpr -> Arity
+manifestArity (Lam v e) | isId v    = 1 + manifestArity e
+                       | otherwise = manifestArity e
+manifestArity (Note _ e)           = manifestArity e
+manifestArity e                            = 0
+
+-- etaExpand deals with for-alls. For example:

 --             etaExpand 1 E
 --             etaExpand 1 E

--- where  E :: forall a. T
---       newtype T = MkT (A -> B)
---
+-- where  E :: forall a. a -> a

 -- would return
 -- would return

---     (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
+--     (/\b. \y::a -> E b y)
+--
+-- It deals with coerces too, though they are now rare
+-- so perhaps the extra code isn't worth it

 
 

-etaExpand n us expr ty
+eta_expand n us expr ty

   | n == 0 && 
     -- The ILX code generator requires eta expansion for type arguments
     -- too, but alas the 'n' doesn't tell us how many of them there 
   | n == 0 && 
     -- The ILX code generator requires eta expansion for type arguments
     -- too, but alas the 'n' doesn't tell us how many of them there 

@@ -765,29 +836,44 @@ etaExpand n us expr ty
     -- Saturated, so nothing to do
   = expr
 
     -- Saturated, so nothing to do
   = expr
 

-  | otherwise  -- An unsaturated constructor or primop; eta expand it
+eta_expand n us (Note note@(Coerce _ ty) e) _
+  = Note note (eta_expand n us e ty)
+
+       -- Use mkNote so that _scc_s get pushed inside any lambdas that
+       -- are generated as part of the eta expansion.  We rely on this
+       -- behaviour in CorePrep, when we eta expand an already-prepped RHS.
+eta_expand n us (Note note e) ty
+  = mkNote note (eta_expand n us e ty)
+
+       -- Short cut for the case where there already
+       -- is a lambda; no point in gratuitously adding more
+eta_expand n us (Lam v body) ty
+  | isTyVar v
+  = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
+
+  | otherwise
+  = Lam v (eta_expand (n-1) us body (funResultTy ty))
+
+eta_expand n us expr ty

   = case splitForAllTy_maybe ty of { 
   = case splitForAllTy_maybe ty of { 

-         Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
+         Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')

 
        ; Nothing ->
   
        case splitFunTy_maybe ty of {
 
        ; Nothing ->
   
        case splitFunTy_maybe ty of {

-         Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
+         Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)

                                where
                                where

-                                  arg1       = mkSysLocal SLIT("eta") uniq arg_ty
-                                  (us1, us2) = splitUniqSupply us
-                                  uniq       = uniqFromSupply us1 
+                                  arg1       = mkSysLocal FSLIT("eta") uniq arg_ty
+                                  (uniq:us2) = us

                                   
                                   

-       ; Nothing -> 
-  
+       ; Nothing ->
+

        case splitNewType_maybe ty of {
        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
+         Just ty' -> mkCoerce ty ty' (eta_expand n us (mkCoerce ty' ty expr) ty') ;
+         Nothing  -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr

        }}}
 \end{code}
 
        }}}
 \end{code}
 

-

 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
 It tells how many things the expression can be applied to before doing
 any work.  It doesn't look inside cases, lets, etc.  The idea is that
 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
 It tells how many things the expression can be applied to before doing
 any work.  It doesn't look inside cases, lets, etc.  The idea is that

@@ -809,21 +895,27 @@ Similarly, see the ok_note check in exprEtaExpandArity.  So
 won't be eta-expanded.
 
 And in any case it seems more robust to have exprArity be a bit more intelligent.
 won't be eta-expanded.
 
 And in any case it seems more robust to have exprArity be a bit more intelligent.

+But note that  (\x y z -> f x y z)
+should have arity 3, regardless of f's arity.

 
 \begin{code}
 
 \begin{code}

-exprArity :: CoreExpr -> Int
-exprArity e = go e `max` 0
+exprArity :: CoreExpr -> Arity
+exprArity e = go e

            where
            where

-             go (Lam x e) | isId x    = go e + 1
-                          | otherwise = go e
-             go (Note _ e)            = go e
-             go (App e (Type t))      = go e
-             go (App f a)             = go f - 1
-             go (Var v)               = idArity v
-             go _                     = 0
+             go (Var v)                   = idArity v
+             go (Lam x e) | isId x        = go e + 1
+                          | otherwise     = go e
+             go (Note n e)                = go e
+             go (App e (Type t))          = go e
+             go (App f a) | exprIsCheap a = (go f - 1) `max` 0
+               -- NB: exprIsCheap a!  
+               --      f (fac x) does not have arity 2, 
+               --      even if f has arity 3!
+               -- NB: `max 0`!  (\x y -> f x) has arity 2, even if f is
+               --               unknown, hence arity 0
+             go _                         = 0

 \end{code}
 
 \end{code}
 

-

 %************************************************************************
 %*                                                                     *
 \subsection{Equality}
 %************************************************************************
 %*                                                                     *
 \subsection{Equality}

@@ -839,7 +931,7 @@ cheapEqExpr :: Expr b -> Expr b -> Bool
 
 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
 
 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2

-cheapEqExpr (Type t1)  (Type t2)  = t1 == t2
+cheapEqExpr (Type t1)  (Type t2)  = t1 `eqType` t2

 
 cheapEqExpr (App f1 a1) (App f2 a2)
   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 
 cheapEqExpr (App f1 a1) (App f2 a2)
   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2

@@ -859,6 +951,9 @@ exprIsBig other            = True
 \begin{code}
 eqExpr :: CoreExpr -> CoreExpr -> Bool
        -- Works ok at more general type, but only needed at CoreExpr
 \begin{code}
 eqExpr :: CoreExpr -> CoreExpr -> Bool
        -- Works ok at more general type, but only needed at CoreExpr

+       -- Used in rule matching, so when we find a type we use
+       -- eqTcType, which doesn't look through newtypes
+       -- [And it doesn't risk falling into a black hole either.]

 eqExpr e1 e2
   = eq emptyVarEnv e1 e2
   where
 eqExpr e1 e2
   = eq emptyVarEnv e1 e2
   where

@@ -875,7 +970,7 @@ eqExpr e1 e2
     eq env (Let (NonRec v1 r1) e1)
           (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
     eq env (Let (Rec ps1) e1)
     eq env (Let (NonRec v1 r1) e1)
           (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
     eq env (Let (Rec ps1) e1)

-          (Let (Rec ps2) e2)        = length ps1 == length ps2 &&
+          (Let (Rec ps2) e2)        = equalLength ps1 ps2 &&

                                       and (zipWith eq_rhs ps1 ps2) &&
                                       eq env' e1 e2
                                     where
                                       and (zipWith eq_rhs ps1 ps2) &&
                                       eq env' e1 e2
                                     where

@@ -883,13 +978,13 @@ eqExpr e1 e2
                                       eq_rhs (_,r1) (_,r2) = eq env' r1 r2
     eq env (Case e1 v1 a1)
           (Case e2 v2 a2)           = eq env e1 e2 &&
                                       eq_rhs (_,r1) (_,r2) = eq env' r1 r2
     eq env (Case e1 v1 a1)
           (Case e2 v2 a2)           = eq env e1 e2 &&

-                                      length a1 == length a2 &&
+                                      equalLength a1 a2 &&

                                       and (zipWith (eq_alt env') a1 a2)
                                     where
                                       env' = extendVarEnv env v1 v2
 
     eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
                                       and (zipWith (eq_alt env') a1 a2)
                                     where
                                       env' = extendVarEnv env v1 v2
 
     eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2

-    eq env (Type t1)    (Type t2)    = t1 == t2
+    eq env (Type t1)    (Type t2)    = t1 `eqType` t2

     eq env e1          e2           = False
                                         
     eq_list env []      []       = True
     eq env e1          e2           = False
                                         
     eq_list env []      []       = True

@@ -900,7 +995,7 @@ eqExpr e1 e2
                                         eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
 
     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
                                         eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
 
     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2

-    eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
+    eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2

     eq_note env InlineCall     InlineCall     = True
     eq_note env other1        other2         = False
 \end{code}
     eq_note env InlineCall     InlineCall     = True
     eq_note env other1        other2         = False
 \end{code}

@@ -919,7 +1014,7 @@ coreBindsSize bs = foldr ((+) . bindSize) 0 bs
 exprSize :: CoreExpr -> Int
        -- A measure of the size of the expressions
        -- It also forces the expression pretty drastically as a side effect
 exprSize :: CoreExpr -> Int
        -- A measure of the size of the expressions
        -- It also forces the expression pretty drastically as a side effect

-exprSize (Var v)       = varSize v 
+exprSize (Var v)       = v `seq` 1

 exprSize (Lit lit)     = lit `seq` 1
 exprSize (App f a)     = exprSize f + exprSize a
 exprSize (Lam b e)     = varSize b + exprSize e
 exprSize (Lit lit)     = lit `seq` 1
 exprSize (App f a)     = exprSize f + exprSize a
 exprSize (Lam b e)     = varSize b + exprSize e