[project @ 2004-11-26 16:19:45 by simonmar]
[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreUtils.lhs
index 1ca6d37..270d44d 100644 (file)
@@ -6,23 +6,23 @@
 \begin{code}
 module CoreUtils (
        -- Construction
-       mkNote, mkInlineMe, mkSCC, mkCoerce,
+       mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
        bindNonRec, needsCaseBinding,
-       mkIfThenElse, mkAltExpr, mkPiType,
+       mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
        -- Taking expressions apart
-       findDefault, findAlt, hasDefault,
+       findDefault, findAlt,
 
        -- Properties of expressions
-       exprType, coreAltsType, 
-       exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, 
+       exprType, coreAltType,
+       exprIsDupable, exprIsTrivial, exprIsCheap, 
        exprIsValue,exprOkForSpeculation, exprIsBig, 
-       exprIsConApp_maybe, exprIsAtom,
-       idAppIsBottom, idAppIsCheap,
-       exprArity, 
+       exprIsConApp_maybe, exprIsBottom,
+       rhsIsStatic,
 
-       -- Expr transformation
-       etaExpand, exprArity, exprEtaExpandArity, 
+       -- Arity and eta expansion
+       manifestArity, exprArity, 
+       exprEtaExpandArity, etaExpand, 
 
        -- Size
        coreBindsSize,
@@ -31,42 +31,49 @@ module CoreUtils (
        hashExpr,
 
        -- Equality
-       cheapEqExpr, eqExpr, applyTypeToArgs
+       cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
     ) where
 
 #include "HsVersions.h"
 
 
-import GlaExts         -- For `xori` 
+import GLAEXTS         -- For `xori` 
 
 import CoreSyn
 import PprCore         ( pprCoreExpr )
 import Var             ( Var, isId, isTyVar )
 import VarEnv
 import Name            ( hashName )
-import Literal         ( hashLiteral, literalType, litIsDupable )
-import DataCon         ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon )
-import PrimOp          ( primOpOkForSpeculation, primOpIsCheap )
-import Id              ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo, 
-                         mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
-                         isDataConId_maybe, mkSysLocal, hasNoBinding, isDataConId, isBottomingId
+import Packages                ( isDllName )
+import CmdLineOpts     ( DynFlags )
+import Literal         ( hashLiteral, literalType, litIsDupable, 
+                         litIsTrivial, isZeroLit, Literal( MachLabel ) )
+import DataCon         ( DataCon, dataConRepArity, dataConArgTys,
+                         isVanillaDataCon, dataConTyCon )
+import PrimOp          ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
+import Id              ( Id, idType, globalIdDetails, idNewStrictness, 
+                         mkWildId, idArity, idName, idUnfolding, idInfo,
+                         isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
+                         isDataConWorkId, isBottomingId
                        )
-import IdInfo          ( LBVarInfo(..),  
-                         GlobalIdDetails(..),
-                         megaSeqIdInfo )
+import IdInfo          ( GlobalIdDetails(..), megaSeqIdInfo )
 import NewDemand       ( appIsBottom )
-import Type            ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
-                         applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
-                         splitForAllTy_maybe, isForAllTy, splitNewType_maybe, 
-                         splitTyConApp_maybe, eqType, funResultTy, applyTy
+import Type            ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
+                         splitFunTy,
+                         applyTys, isUnLiftedType, seqType, mkTyVarTy,
+                         splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, 
+                         splitTyConApp_maybe, eqType, funResultTy, applyTy,
+                         funResultTy, applyTy
                        )
 import TyCon           ( tyConArity )
+-- gaw 2004
 import TysWiredIn      ( boolTy, trueDataCon, falseDataCon )
 import CostCentre      ( CostCentre )
 import BasicTypes      ( Arity )
 import Unique          ( Unique )
 import Outputable
 import TysPrim         ( alphaTy )     -- Debugging only
+import Util             ( equalLength, lengthAtLeast )
 \end{code}
 
 
@@ -82,7 +89,8 @@ exprType :: CoreExpr -> Type
 exprType (Var var)             = idType var
 exprType (Lit lit)             = literalType lit
 exprType (Let _ body)          = exprType body
-exprType (Case _ _ alts)        = coreAltsType alts
+-- gaw 2004
+exprType (Case _ _ ty alts)     = ty
 exprType (Note (Coerce ty _) e) = ty  -- **! should take usage from e
 exprType (Note other_note e)    = exprType e
 exprType (Lam binder expr)      = mkPiType binder (exprType expr)
@@ -92,8 +100,8 @@ exprType e@(App _ _)
 
 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
 
-coreAltsType :: [CoreAlt] -> Type
-coreAltsType ((_,_,rhs) : _) = exprType rhs
+coreAltType :: CoreAlt -> Type
+coreAltType (_,_,rhs) = exprType rhs
 \end{code}
 
 @mkPiType@ makes a (->) type or a forall type, depending on whether
@@ -102,26 +110,35 @@ lbvarinfo field to figure out the right annotation for the arrove in
 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}
--- 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
+-- 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 (applyTys op_ty tys) rest_args
+    go [ty] args
   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
@@ -140,11 +157,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 = mkCoerce to_ty from_ty expr
+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)
@@ -182,13 +201,15 @@ mkInlineMe e         = Note InlineMe e
 
 
 \begin{code}
-mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
+mkCoerce :: Type -> CoreExpr -> CoreExpr
+mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
 
-mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
+mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
+mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
   = ASSERT( from_ty `eqType` to_ty2 )
-    mkCoerce to_ty from_ty2 expr
+    mkCoerce2 to_ty from_ty2 expr
 
-mkCoerce to_ty from_ty expr
+mkCoerce2 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
@@ -223,8 +244,10 @@ bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 -- It's used by the desugarer to avoid building bindings
 -- that give Core Lint a heart attack.  Actually the simplifier
 -- deals with them perfectly well.
+
 bindNonRec bndr rhs body 
-  | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
+-- gaw 2004
+  | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
   | otherwise                         = Let (NonRec bndr rhs) body
 
 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
@@ -244,7 +267,9 @@ mkAltExpr (LitAlt lit) [] []
 
 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 mkIfThenElse guard then_expr else_expr
-  = Case guard (mkWildId boolTy) 
+-- gaw 2004
+-- Not going to be refining, so okay to take the type of the "then" clause
+  = Case guard (mkWildId boolTy) (exprType then_expr) 
         [ (DataAlt trueDataCon,  [], then_expr),
           (DataAlt falseDataCon, [], else_expr) ]
 \end{code}
@@ -260,10 +285,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)
@@ -298,36 +319,31 @@ findAlt con alts
 @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.
+
+SCC notes.  We do not treat (_scc_ "foo" x) as trivial, because 
+  a) it really generates code, (and a heap object when it's 
+     a function arg) to capture the cost centre
+  b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
+
 \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
-
-exprIsAtom :: CoreExpr -> Bool
--- Used to decide whether to let-binding an STG argument
--- when compiling to ILX => type applications are not allowed
-exprIsAtom (Var v)    = True   -- primOpIsDupable?
-exprIsAtom (Lit lit)  = True
-exprIsAtom (Type ty)  = True
-exprIsAtom (Note (SCC _) e) = False
-exprIsAtom (Note _ e) = exprIsAtom e
-exprIsAtom other      = False
+exprIsTrivial (Var v)     = True       -- See notes above
+exprIsTrivial (Type _)    = True
+exprIsTrivial (Lit lit)    = litIsTrivial lit
+exprIsTrivial (App e arg)  = not (isRuntimeArg arg) && exprIsTrivial e
+exprIsTrivial (Note (SCC _) e) = False         -- See notes above
+exprIsTrivial (Note _       e) = exprIsTrivial e
+exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
+exprIsTrivial other       = False
 \end{code}
 
 
@@ -391,13 +407,14 @@ because sharing will make sure it is only evaluated once.
 
 \begin{code}
 exprIsCheap :: CoreExpr -> Bool
-exprIsCheap (Lit lit)            = True
-exprIsCheap (Type _)             = True
-exprIsCheap (Var _)              = True
-exprIsCheap (Note InlineMe e)            = True
-exprIsCheap (Note _ e)           = exprIsCheap e
-exprIsCheap (Lam x e)            = isRuntimeVar x || exprIsCheap e
-exprIsCheap (Case e _ alts)       = exprIsCheap e && 
+exprIsCheap (Lit lit)              = True
+exprIsCheap (Type _)               = True
+exprIsCheap (Var _)                = True
+exprIsCheap (Note InlineMe e)              = True
+exprIsCheap (Note _ e)             = exprIsCheap e
+exprIsCheap (Lam x e)               = isRuntimeVar x || exprIsCheap e
+-- gaw 2004
+exprIsCheap (Case e _ _ alts)       = exprIsCheap e && 
                                    and [exprIsCheap rhs | (_,_,rhs) <- alts]
        -- Experimentally, treat (case x of ...) as cheap
        -- (and case __coerce x etc.)
@@ -433,10 +450,10 @@ idAppIsCheap id n_val_args
                                -- a variable (f t1 t2 t3)
                                -- counts as WHNF
   | otherwise = case globalIdDetails id of
-                 DataConId _   -> True                 
-                 RecordSelId _ -> True                 -- I'm experimenting with making record selection
-                                                       -- look cheap, so we will substitute it inside a
-                                                       -- lambda.  Particularly for dictionary field selection
+                 DataConWorkId _ -> True                       
+                 RecordSelId _ _ -> True       -- I'm experimenting with making record selection
+                 ClassOpId _     -> True       -- look cheap, so we will substitute it inside a
+                                               -- lambda.  Particularly for dictionary field selection
 
                  PrimOpId op   -> primOpIsCheap op     -- In principle we should worry about primops
                                                        -- that return a type variable, since the result
@@ -474,28 +491,50 @@ side effects, and can't diverge or raise an exception.
 \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
-  = go other_expr 0 True
+  = case collectArgs other_expr of
+       (Var f, args) -> spec_ok (globalIdDetails f) args
+       other         -> False
   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 (DataConWorkId _) 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
 
-         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}
 
 
@@ -504,13 +543,14 @@ exprIsBottom :: CoreExpr -> Bool  -- True => definitely bottom
 exprIsBottom e = go 0 e
               where
                -- n is the number of args
-                go n (Note _ e)   = go n e
-                go n (Let _ e)    = go n e
-                go n (Case e _ _) = go 0 e     -- Just check the scrut
-                go n (App e _)    = go (n+1) e
-                go n (Var v)      = idAppIsBottom v n
-                go n (Lit _)      = False
-                go n (Lam _ _)    = False
+                go n (Note _ e)     = go n e
+                go n (Let _ e)      = go n e
+-- gaw 2004
+                go n (Case e _ _ _) = go 0 e   -- Just check the scrut
+                go n (App e _)      = go (n+1) e
+                go n (Var v)        = idAppIsBottom v n
+                go n (Lit _)        = False
+                go n (Lam _ _)      = False
 
 idAppIsBottom :: Id -> Int -> Bool
 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
@@ -541,33 +581,42 @@ type must be ok-for-speculation (or trivial).
 
 \begin{code}
 exprIsValue :: CoreExpr -> Bool                -- True => Value-lambda, constructor, PAP
-exprIsValue (Type ty)    = True        -- Types are honorary Values; we don't mind
-                                       -- copying them
-exprIsValue (Lit l)      = True
-exprIsValue (Lam b e)            = isRuntimeVar b || exprIsValue e
-exprIsValue (Note _ e)           = exprIsValue e
-exprIsValue (Var v)      = idArity v > 0 || isEvaldUnfolding (idUnfolding v)
-       -- The idArity case catches data cons and primops that 
-       -- don't have unfoldings
+exprIsValue (Var v)    -- NB: There are no value args at this point
+  =  isDataConWorkId v         -- Catches nullary constructors, 
+                       --      so that [] and () are values, for example
+  || idArity v > 0     -- Catches (e.g.) primops that don't have unfoldings
+  || isEvaldUnfolding (idUnfolding v)
+       -- Check the thing's unfolding; it might be bound to a value
        -- A worry: what if an Id's unfolding is just itself: 
        -- then we could get an infinite loop...
-exprIsValue other_expr
-  | (Var fun, args) <- collectArgs other_expr,
-    isDataConId fun || valArgCount args < idArity fun
-  = check (idType fun) args
-  | otherwise
-  = False
+
+exprIsValue (Lit l)         = True
+exprIsValue (Type ty)       = True     -- Types are honorary Values; 
+                                       -- we don't mind copying them
+exprIsValue (Lam b e)               = isRuntimeVar b || exprIsValue e
+exprIsValue (Note _ e)              = exprIsValue e
+exprIsValue (App e (Type _)) = exprIsValue e
+exprIsValue (App e a)        = app_is_value e [a]
+exprIsValue other           = False
+
+-- There is at least one value argument
+app_is_value (Var fun) args
+  |  isDataConWorkId fun                       -- Constructor apps are values
+  || idArity fun > valArgCount args    -- Under-applied function
+  = check_args (idType fun) args
+app_is_value (App f a) as = app_is_value f (a:as)
+app_is_value other     as = False
+
+       -- 'check_args' checks that unlifted-type args
+       -- are in fact guaranteed non-divergent
+check_args fun_ty []             = True
+check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
+                                     Just (_, ty) -> check_args ty args
+check_args fun_ty (arg : args)
+  | isUnLiftedType arg_ty = exprOkForSpeculation arg
+  | otherwise            = check_args res_ty args
   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
+    (arg_ty, res_ty) = splitFunTy fun_ty
 \end{code}
 
 \begin{code}
@@ -588,20 +637,20 @@ exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
   
     case splitTyConApp_maybe to_ty of {
        Nothing -> Nothing ;
-       Just (tc, tc_arg_tys) | tc /= dataConTyCon dc   -> Nothing
-                             | isExistentialDataCon dc -> Nothing
-                             | otherwise               ->
+       Just (tc, tc_arg_tys) | tc /= dataConTyCon dc     -> Nothing
+                             | not (isVanillaDataCon 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
+       mk_coerce ty arg = mkCoerce ty arg
        new_val_args     = zipWith mk_coerce to_arg_tys val_args
     in
     ASSERT( all isTypeArg (take arity args) )
-    ASSERT( length val_args == length to_arg_tys )
+    ASSERT( equalLength val_args to_arg_tys )
     Just (dc, map Type tc_arg_tys ++ new_val_args)
     }}
 
@@ -621,8 +670,8 @@ exprIsConApp_maybe (Note _ expr)
 exprIsConApp_maybe expr = analyse (collectArgs expr)
   where
     analyse (Var fun, args)
-       | Just con <- isDataConId_maybe fun,
-         length args >= dataConRepArity con
+       | Just con <- isDataConWorkId_maybe fun,
+         args `lengthAtLeast` dataConRepArity con
                -- Might be > because the arity excludes type args
        = Just (con,args)
 
@@ -646,38 +695,62 @@ exprIsConApp_maybe expr = analyse (collectArgs expr)
 
 \begin{code}
 exprEtaExpandArity :: CoreExpr -> Arity
--- The Int is number of value args the thing can be 
---     applied to without doing much work
---
--- This is used when eta expanding
---     e  ==>  \xy -> e x y
---
--- It returns 1 (or more) to:
---     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
-
--- 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
--- 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
+{- The Arity returned is the number of value args the 
+   thing can be applied to without doing much work
+
+exprEtaExpandArity is used when eta expanding
+       e  ==>  \xy -> e x y
+
+It returns 1 (or more) to:
+       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
+
+It's all a bit more subtle than it looks:
+
+1.  One-shot lambdas
+
+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
+Hence the ArityType returned by arityType
+
+2.  The state-transformer hack
+
+The one-shot lambda special cause 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, even if E is expensive.  So we treat state-token lambdas as 
+one-shot even if they aren't really.  The hack is in Id.isOneShotBndr.
+
+3.  Dealing with bottom
+
+Consider also 
+       f = \x -> error "foo"
+Here, arity 1 is fine.  But if it is
+       f = \x -> case x of 
+                       True  -> error "foo"
+                       False -> \y -> x+y
+then we want to get arity 2.  Tecnically, this isn't quite right, because
+       (f True) `seq` 1
+should diverge, but it'll converge if we eta-expand f.  Nevertheless, we
+do so; it improves some programs significantly, and increasing convergence
+isn't a bad thing.  Hence the ABot/ATop in ArityType.
+
+Actually, the situation is worse.  Consider
+       f = \x -> case x of
+                       True  -> \y -> x+y
+                       False -> \y -> x-y
+Can we eta-expand here?  At first the answer looks like "yes of course", but
+consider
+       (f bot) `seq` 1
+This should diverge!  But if we eta-expand, it won't.   Again, we ignore this
+"problem", because being scrupulous would lose an important transformation for
+many programs.
+-}
 
 
 exprEtaExpandArity e = arityDepth (arityType e)
@@ -707,30 +780,45 @@ arityType (Note n e) = arityType e
 --  | otherwise = ATop
 
 arityType (Var v) 
-  = mk (idArity v)
+  = mk (idArity v) (arg_tys (idType 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
+    mk :: Arity -> [Type] -> ArityType
+       -- The argument types are only to steer the "state hack"
+       -- Consider case x of
+       --              True  -> foo
+       --              False -> \(s:RealWorld) -> e
+       -- where foo has arity 1.  Then we want the state hack to
+       -- apply to foo too, so we can eta expand the case.
+    mk 0 tys | isBottomingId v  = ABot
+             | otherwise       = ATop
+    mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
+    mk n []       = AFun False               (mk (n-1) [])
+
+    arg_tys :: Type -> [Type]  -- Ignore for-alls
+    arg_tys ty 
+       | Just (_, ty')  <- splitForAllTy_maybe ty = arg_tys ty'
+       | Just (arg,res) <- splitFunTy_maybe ty    = arg : arg_tys res
+       | otherwise                                = []
 
        -- Lambdas; increase arity
-arityType (Lam x e) | isId x    = AFun (isOneShotLambda x) (arityType e)
+arityType (Lam x e) | isId x    = AFun (isOneShotBndr x) (arityType e)
                    | otherwise = arityType e
 
        -- Applications; decrease arity
 arityType (App f (Type _)) = arityType f
 arityType (App f a)       = case arityType f of
-                               AFun one_shot xs | one_shot      -> xs
-                                                | exprIsCheap a -> xs
+                               AFun 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
-arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
+       -- 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'
+-- gaw 2004  
+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
@@ -769,6 +857,11 @@ etaExpand :: Arity         -- Result should have this number of value args
 -- Given e' = etaExpand n us e ty
 -- We should have
 --     ty = exprType e = exprType e'
+--
+-- Note that SCCs are not treated specially.  If we have
+--     etaExpand 2 (\x -> scc "foo" e)
+--     = (\xy -> (scc "foo" e) y)
+-- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
 
 etaExpand n us expr ty
   | manifestArity expr >= n = expr             -- The no-op case
@@ -796,8 +889,7 @@ eta_expand n us expr ty
     -- The ILX code generator requires eta expansion for type arguments
     -- too, but alas the 'n' doesn't tell us how many of them there 
     -- may be.  So we eagerly eta expand any big lambdas, and just
-    -- cross our fingers about possible loss of sharing in the
-    -- ILX case. 
+    -- cross our fingers about possible loss of sharing in the ILX case. 
     -- The Right Thing is probably to make 'arity' include
     -- type variables throughout the compiler.  (ToDo.)
     not (isForAllTy ty)        
@@ -806,12 +898,6 @@ eta_expand n us expr ty
 
        -- Short cut for the case where there already
        -- is a lambda; no point in gratuitously adding more
-eta_expand n us (Note note@(Coerce _ ty) e) _
-  = Note note (eta_expand n us e ty)
-
-eta_expand n us (Note note e) ty
-  = Note note (eta_expand n us e ty)
-
 eta_expand n us (Lam v body) ty
   | isTyVar v
   = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
@@ -819,6 +905,19 @@ eta_expand n us (Lam v body) ty
   | otherwise
   = Lam v (eta_expand (n-1) us body (funResultTy ty))
 
+-- We used to have a special case that stepped inside Coerces here,
+-- thus:  eta_expand n us (Note note@(Coerce _ ty) e) _  
+--             = Note note (eta_expand n us e ty)
+-- BUT this led to an infinite loop
+-- Example:    newtype T = MkT (Int -> Int)
+--     eta_expand 1 (coerce (Int->Int) e)
+--     --> coerce (Int->Int) (eta_expand 1 T e)
+--             by the bogus eqn
+--     --> coerce (Int->Int) (coerce T 
+--             (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
+--             by the splitNewType_maybe case below
+--     and round we go
+
 eta_expand n us expr ty
   = case splitForAllTy_maybe ty of { 
          Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
@@ -828,14 +927,23 @@ eta_expand n us expr ty
        case splitFunTy_maybe ty of {
          Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
                                where
-                                  arg1       = mkSysLocal SLIT("eta") uniq arg_ty
+                                  arg1       = mkSysLocal FSLIT("eta") uniq arg_ty
                                   (uniq:us2) = us
                                   
        ; Nothing ->
 
-       case splitNewType_maybe ty of {
-         Just ty' -> mkCoerce ty ty' (eta_expand n us (mkCoerce ty' ty expr) ty') ;
-         Nothing  -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
+               -- Given this:
+               --      newtype T = MkT ([T] -> Int)
+               -- Consider eta-expanding this
+               --      eta_expand 1 e T
+               -- We want to get
+               --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
+               -- Only try this for recursive newtypes; the non-recursive kind
+               -- are transparent anyway
+
+       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 n $$ ppr expr $$ ppr ty) expr
        }}}
 \end{code}
 
@@ -881,7 +989,6 @@ exprArity e = go e
              go _                         = 0
 \end{code}
 
-
 %************************************************************************
 %*                                                                     *
 \subsection{Equality}
@@ -936,15 +1043,17 @@ 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)
-          (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
                                       env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
                                       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 &&
+-- gaw 2004
+    eq env (Case e1 v1 t1 a1)
+          (Case e2 v2 t2 a2)        = eq env e1 e2 &&
+                                       t1 `eqType` t2 &&                      
+                                      equalLength a1 a2 &&
                                       and (zipWith (eq_alt env') a1 a2)
                                     where
                                       env' = extendVarEnv env v1 v2
@@ -963,6 +1072,7 @@ eqExpr e1 e2
     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
     eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
     eq_note env InlineCall     InlineCall     = True
+    eq_note env (CoreNote s1)  (CoreNote s2)  = s1 == s2
     eq_note env other1        other2         = False
 \end{code}
 
@@ -980,19 +1090,21 @@ 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 (Var v)       = varSize v 
-exprSize (Lit lit)     = lit `seq` 1
-exprSize (App f a)     = exprSize f + exprSize a
-exprSize (Lam b e)     = varSize b + exprSize e
-exprSize (Let b e)     = bindSize b + exprSize e
-exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
-exprSize (Note n e)    = noteSize n + exprSize e
-exprSize (Type t)      = seqType t `seq` 1
+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 (Let b e)       = bindSize b + exprSize e
+-- gaw 2004
+exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
+exprSize (Note n e)      = noteSize n + exprSize e
+exprSize (Type t)        = seqType t `seq` 1
 
 noteSize (SCC cc)       = cc `seq` 1
 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
 noteSize InlineCall     = 1
 noteSize InlineMe       = 1
+noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
 
 varSize :: Var -> Int
 varSize b  | isTyVar b = 1
@@ -1027,7 +1139,8 @@ hashExpr e | hash < 0  = 77       -- Just in case we hit -maxInt
 hash_expr (Note _ e)                     = hash_expr e
 hash_expr (Let (NonRec b r) e)    = hashId b
 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
-hash_expr (Case _ b _)           = hashId b
+-- gaw 2004
+hash_expr (Case _ b _ _)         = hashId b
 hash_expr (App f e)              = hash_expr f * fast_hash_expr e
 hash_expr (Var v)                = hashId v
 hash_expr (Lit lit)              = hashLiteral lit
@@ -1044,3 +1157,135 @@ fast_hash_expr other            = 1
 hashId :: Id -> Int
 hashId id = hashName (idName id)
 \end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection{Determining non-updatable right-hand-sides}
+%*                                                                     *
+%************************************************************************
+
+Top-level constructor applications can usually be allocated
+statically, but they can't if the constructor, or any of the
+arguments, come from another DLL (because we can't refer to static
+labels in other DLLs).
+
+If this happens we simply make the RHS into an updatable thunk, 
+and 'exectute' it rather than allocating it statically.
+
+\begin{code}
+rhsIsStatic :: DynFlags -> CoreExpr -> Bool
+-- This function is called only on *top-level* right-hand sides
+-- Returns True if the RHS can be allocated statically, with
+-- no thunks involved at all.
+--
+-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
+-- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
+-- update flag on it.
+--
+-- The basic idea is that rhsIsStatic returns True only if the RHS is
+--     (a) a value lambda
+--     (b) a saturated constructor application with static args
+--
+-- BUT watch out for
+--  (i)        Any cross-DLL references kill static-ness completely
+--     because they must be 'executed' not statically allocated
+--
+-- (ii) We treat partial applications as redexes, because in fact we 
+--     make a thunk for them that runs and builds a PAP
+--     at run-time.  The only appliations that are treated as 
+--     static are *saturated* applications of constructors.
+
+-- We used to try to be clever with nested structures like this:
+--             ys = (:) w ((:) w [])
+-- on the grounds that CorePrep will flatten ANF-ise it later.
+-- But supporting this special case made the function much more 
+-- complicated, because the special case only applies if there are no 
+-- enclosing type lambdas:
+--             ys = /\ a -> Foo (Baz ([] a))
+-- Here the nested (Baz []) won't float out to top level in CorePrep.
+--
+-- But in fact, even without -O, nested structures at top level are 
+-- flattened by the simplifier, so we don't need to be super-clever here.
+--
+-- Examples
+--
+--     f = \x::Int. x+7        TRUE
+--     p = (True,False)        TRUE
+--
+--     d = (fst p, False)      FALSE because there's a redex inside
+--                             (this particular one doesn't happen but...)
+--
+--     h = D# (1.0## /## 2.0##)        FALSE (redex again)
+--     n = /\a. Nil a                  TRUE
+--
+--     t = /\a. (:) (case w a of ...) (Nil a)  FALSE (redex)
+--
+--
+-- This is a bit like CoreUtils.exprIsValue, with the following differences:
+--    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
+--
+--    b) (C x xs), where C is a contructors is updatable if the application is
+--        dynamic
+-- 
+--    c) don't look through unfolding of f in (f x).
+--
+-- When opt_RuntimeTypes is on, we keep type lambdas and treat
+-- them as making the RHS re-entrant (non-updatable).
+
+rhsIsStatic dflags rhs = is_static False rhs
+  where
+  is_static :: Bool    -- True <=> in a constructor argument; must be atomic
+         -> CoreExpr -> Bool
+  
+  is_static False (Lam b e) = isRuntimeVar b || is_static False e
+  
+  is_static in_arg (Note (SCC _) e) = False
+  is_static in_arg (Note _ e)       = is_static in_arg e
+  
+  is_static in_arg (Lit lit)
+    = case lit of
+       MachLabel _ _ -> False
+       other         -> True
+       -- A MachLabel (foreign import "&foo") in an argument
+       -- prevents a constructor application from being static.  The
+       -- reason is that it might give rise to unresolvable symbols
+       -- in the object file: under Linux, references to "weak"
+       -- symbols from the data segment give rise to "unresolvable
+       -- relocation" errors at link time This might be due to a bug
+       -- in the linker, but we'll work around it here anyway. 
+       -- SDM 24/2/2004
+  
+  is_static in_arg other_expr = go other_expr 0
+   where
+    go (Var f) n_val_args
+       | not (isDllName dflags (idName f))
+       =  saturated_data_con f n_val_args
+       || (in_arg && n_val_args == 0)  
+               -- A naked un-applied variable is *not* deemed a static RHS
+               -- E.g.         f = g
+               -- Reason: better to update so that the indirection gets shorted
+               --         out, and the true value will be seen
+               -- NB: if you change this, you'll break the invariant that THUNK_STATICs
+               --     are always updatable.  If you do so, make sure that non-updatable
+               --     ones have enough space for their static link field!
+
+    go (App f a) n_val_args
+       | isTypeArg a                    = go f n_val_args
+       | not in_arg && is_static True a = go f (n_val_args + 1)
+       -- The (not in_arg) checks that we aren't in a constructor argument;
+       -- if we are, we don't allow (value) applications of any sort
+       -- 
+        -- NB. In case you wonder, args are sometimes not atomic.  eg.
+        --   x = D# (1.0## /## 2.0##)
+        -- can't float because /## can fail.
+
+    go (Note (SCC _) f) n_val_args = False
+    go (Note _ f) n_val_args       = go f n_val_args
+
+    go other n_val_args = False
+
+    saturated_data_con f n_val_args
+       = case isDataConWorkId_maybe f of
+           Just dc -> n_val_args == dataConRepArity dc
+           Nothing -> False
+\end{code}