[project @ 2004-11-10 03:20:31 by wolfgang]

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

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 7aa9b22..440365d 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -6,18 +6,18 @@
 \begin{code}
 module CoreUtils (
        -- Construction
 \begin{code}
 module CoreUtils (
        -- Construction

-       mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
+       mkInlineMe, mkSCC, mkCoerce, mkCoerce2,

        bindNonRec, needsCaseBinding,
        mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
        -- Taking expressions apart
        bindNonRec, needsCaseBinding,
        mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
        -- Taking expressions apart

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

 
        -- Properties of expressions
 
        -- Properties of expressions

-       exprType, coreAltsType, 
-       exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, 
+       exprType, coreAltType,
+       exprIsDupable, exprIsTrivial, exprIsCheap, 

        exprIsValue,exprOkForSpeculation, exprIsBig, 
        exprIsValue,exprOkForSpeculation, exprIsBig, 

-       exprIsConApp_maybe, 
+       exprIsConApp_maybe, exprIsBottom,

        rhsIsStatic,
 
        -- Arity and eta expansion
        rhsIsStatic,
 
        -- Arity and eta expansion

@@ -45,13 +45,13 @@ import Var          ( Var, isId, isTyVar )
 import VarEnv
 import Name            ( hashName, isDllName )
 import Literal         ( hashLiteral, literalType, litIsDupable, 
 import VarEnv
 import Name            ( hashName, isDllName )
 import Literal         ( hashLiteral, literalType, litIsDupable, 

-                         litIsTrivial, isZeroLit, isLitLitLit )
+                         litIsTrivial, isZeroLit, Literal( MachLabel ) )

 import DataCon         ( DataCon, dataConRepArity, dataConArgTys,
 import DataCon         ( DataCon, dataConRepArity, dataConArgTys,

-                         isExistentialDataCon, dataConTyCon, dataConName )
+                         isVanillaDataCon, dataConTyCon )

 import PrimOp          ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
 import Id              ( Id, idType, globalIdDetails, idNewStrictness, 
                          mkWildId, idArity, idName, idUnfolding, idInfo,
 import PrimOp          ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
 import Id              ( Id, idType, globalIdDetails, idNewStrictness, 
                          mkWildId, idArity, idName, idUnfolding, idInfo,

-                         isOneShotLambda, isDataConWorkId_maybe, mkSysLocal,
+                         isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,

                          isDataConWorkId, isBottomingId
                        )
 import IdInfo          ( GlobalIdDetails(..), megaSeqIdInfo )
                          isDataConWorkId, isBottomingId
                        )
 import IdInfo          ( GlobalIdDetails(..), megaSeqIdInfo )

@@ -59,11 +59,12 @@ import NewDemand    ( appIsBottom )
 import Type            ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
                          splitFunTy,
                          applyTys, isUnLiftedType, seqType, mkTyVarTy,
 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
                        )
 import TyCon           ( tyConArity )
                          splitTyConApp_maybe, eqType, funResultTy, applyTy,
                          funResultTy, applyTy
                        )
 import TyCon           ( tyConArity )

+-- gaw 2004

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

@@ -71,7 +72,6 @@ import Unique         ( Unique )
 import Outputable
 import TysPrim         ( alphaTy )     -- Debugging only
 import Util             ( equalLength, lengthAtLeast )
 import Outputable
 import TysPrim         ( alphaTy )     -- Debugging only
 import Util             ( equalLength, lengthAtLeast )

-import TysPrim         ( statePrimTyCon )

 \end{code}
 
 
 \end{code}
 
 

@@ -87,7 +87,8 @@ exprType :: CoreExpr -> Type
 exprType (Var var)             = idType var
 exprType (Lit lit)             = literalType lit
 exprType (Let _ body)          = exprType body
 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)
 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)

@@ -97,8 +98,8 @@ exprType e@(App _ _)
 
 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
 
 
 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
 \end{code}
 
 @mkPiType@ makes a (->) type or a forall type, depending on whether

@@ -154,11 +155,13 @@ applyTypeToArgs e op_ty (other_arg : args)
 mkNote removes redundant coercions, and SCCs where possible
 
 \begin{code}
 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
 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)
 
 -- Slide InlineCall in around the function
 --     No longer necessary I think (SLPJ Apr 99)

@@ -239,8 +242,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.
 -- 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 
 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)
   | otherwise                         = Let (NonRec bndr rhs) body
 
 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)

@@ -260,7 +265,9 @@ mkAltExpr (LitAlt lit) [] []
 
 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 mkIfThenElse guard then_expr else_expr
 
 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}
         [ (DataAlt trueDataCon,  [], then_expr),
           (DataAlt falseDataCon, [], else_expr) ]
 \end{code}

@@ -276,10 +283,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}
 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)
 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
 findDefault alts                       =                     (alts, Nothing)

@@ -325,12 +328,18 @@ 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.
 
 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)     = True       -- See notes above
 exprIsTrivial (Type _)    = True
 exprIsTrivial (Lit lit)    = litIsTrivial lit
 exprIsTrivial (App e arg)  = not (isRuntimeArg arg) && exprIsTrivial e
 \begin{code}
 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 _ e)   = 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}
 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
 exprIsTrivial other       = False
 \end{code}

@@ -396,13 +405,14 @@ because sharing will make sure it is only evaluated once.
 
 \begin{code}
 exprIsCheap :: CoreExpr -> Bool
 
 \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.)
                                    and [exprIsCheap rhs | (_,_,rhs) <- alts]
        -- Experimentally, treat (case x of ...) as cheap
        -- (and case __coerce x etc.)

@@ -439,7 +449,7 @@ idAppIsCheap id n_val_args
                                -- counts as WHNF
   | otherwise = case globalIdDetails id of
                  DataConWorkId _ -> True                       
                                -- counts as WHNF
   | otherwise = case globalIdDetails id of
                  DataConWorkId _ -> True                       

-                 RecordSelId _   -> True       -- I'm experimenting with making record selection
+                 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
 
                  ClassOpId _     -> True       -- look cheap, so we will substitute it inside a
                                                -- lambda.  Particularly for dictionary field selection
 

@@ -531,13 +541,14 @@ exprIsBottom :: CoreExpr -> Bool  -- True => definitely bottom
 exprIsBottom e = go 0 e
               where
                -- n is the number of args
 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
 
 idAppIsBottom :: Id -> Int -> Bool
 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args

@@ -624,9 +635,9 @@ exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
   
     case splitTyConApp_maybe to_ty of {
        Nothing -> Nothing ;
   
     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
                -- Type constructor must match
                -- We knock out existentials to keep matters simple(r)
     let

@@ -711,7 +722,7 @@ IO state transformers, where we often get
 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 
 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.isOneShotLambda.
+one-shot even if they aren't really.  The hack is in Id.isOneShotBndr.

 
 3.  Dealing with bottom
 
 
 3.  Dealing with bottom
 

@@ -767,18 +778,28 @@ arityType (Note n e) = arityType e
 --  | otherwise = ATop
 
 arityType (Var v) 
 --  | otherwise = ATop
 
 arityType (Var v) 

-  = mk (idArity v)
+  = mk (idArity v) (arg_tys (idType v))

   where
   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
 
        -- Lambdas; increase arity

-arityType (Lam x e) | isId x    = AFun (isOneShotLambda x || isStateHack x) (arityType e)
+arityType (Lam x e) | isId x    = AFun (isOneShotBndr x) (arityType e)

                    | otherwise = arityType e
 
        -- Applications; decrease arity
                    | otherwise = arityType e
 
        -- Applications; decrease arity

@@ -789,7 +810,13 @@ 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
                                                           
        -- 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
                                  xs@(AFun one_shot _) | one_shot -> xs
                                  xs | exprIsCheap scrut          -> xs
                                     | otherwise                  -> ATop

@@ -801,28 +828,6 @@ arityType (Let b e) = case arityType e of
 
 arityType other = ATop
 
 
 arityType other = ATop
 

-isStateHack id = case splitTyConApp_maybe (idType id) of
-                     Just (tycon,_) | tycon == statePrimTyCon -> True
-                     other                                    -> False
-
-       -- The last clause is a gross hack.  It claims that 
-       -- every function over realWorldStatePrimTy is a one-shot
-       -- function.  This is pretty true in practice, and makes a big
-       -- difference.  For example, consider
-       --      a `thenST` \ r -> ...E...
-       -- The early full laziness pass, if it doesn't know that r is one-shot
-       -- will pull out E (let's say it doesn't mention r) to give
-       --      let lvl = E in a `thenST` \ r -> ...lvl...
-       -- When `thenST` gets inlined, we end up with
-       --      let lvl = E in \s -> case a s of (r, s') -> ...lvl...
-       -- and we don't re-inline E.
-       --
-       -- It would be better to spot that r was one-shot to start with, but
-       -- I don't want to rely on that.
-       --
-       -- Another good example is in fill_in in PrelPack.lhs.  We should be able to
-       -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
-

 {- NOT NEEDED ANY MORE: etaExpand is cleverer
 ok_note InlineMe = False
 ok_note other    = True
 {- NOT NEEDED ANY MORE: etaExpand is cleverer
 ok_note InlineMe = False
 ok_note other    = True

@@ -926,15 +931,17 @@ eta_expand n us expr ty
        ; Nothing ->
 
                -- Given this:
        ; 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
                -- 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') ;
          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}
 
        }}}
 \end{code}
 

@@ -1040,8 +1047,10 @@ eqExpr e1 e2
                                     where
                                       env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
                                       eq_rhs (_,r1) (_,r2) = eq env' r1 r2
                                     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 &&
+-- 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
                                       equalLength a1 a2 &&
                                       and (zipWith (eq_alt env') a1 a2)
                                     where

@@ -1079,14 +1088,15 @@ 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)       = 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
-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 (SCC cc)       = cc `seq` 1
 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1

@@ -1127,7 +1137,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 (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
 hash_expr (App f e)              = hash_expr f * fast_hash_expr e
 hash_expr (Var v)                = hashId v
 hash_expr (Lit lit)              = hashLiteral lit

@@ -1151,11 +1162,10 @@ hashId id = hashName (idName id)
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-Top-level constructor applications can usually be allocated 
-statically, but they can't if 
-   a) the constructor, or any of the arguments, come from another DLL
-   b) any of the arguments are LitLits
-(because we can't refer to static labels in other DLLs).
+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.
 
 If this happens we simply make the RHS into an updatable thunk, 
 and 'exectute' it rather than allocating it statically.

@@ -1230,15 +1240,32 @@ 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 (Note (SCC _) e) = False
 is_static in_arg (Note _ e)       = is_static in_arg e
 

-is_static in_arg (Lit lit)        = not (isLitLitLit lit)
-       -- lit-lit arguments cannot be used in static constructors either.  
-       -- (litlits are deprecated, so I'm not going to bother cleaning up this infelicity --SDM).
+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 (idName f))
 
 is_static in_arg other_expr = go other_expr 0
   where
     go (Var f) n_val_args
        | not (isDllName (idName f))

-       = n_val_args == 0 || saturated_data_con f n_val_args
+       =  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
 
     go (App f a) n_val_args
        | isTypeArg a                    = go f n_val_args