[project @ 2003-06-09 15:37:37 by simonpj]
[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreUtils.lhs
index 2000b32..28fb335 100644 (file)
@@ -1,71 +1,80 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[CoreUtils]{Utility functions on @Core@ syntax}
 
 \begin{code}
-#include "HsVersions.h"
-
 module CoreUtils (
-       coreExprType, coreAltsType,
+       -- Construction
+       mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
+       bindNonRec, needsCaseBinding,
+       mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
-       substCoreExpr, substCoreBindings
+       -- Taking expressions apart
+       findDefault, findAlt, hasDefault,
 
-       , mkCoreIfThenElse
-       , argToExpr
-       , unTagBinders, unTagBindersAlts
-       , manifestlyWHNF, manifestlyBottom
-       , maybeErrorApp
-       , nonErrorRHSs
-       , squashableDictishCcExpr
-       , exprSmallEnoughToDup
-{-     
-       coreExprArity,
-       isWrapperFor,
+       -- Properties of expressions
+       exprType, coreAltsType, 
+       exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, 
+       exprIsValue,exprOkForSpeculation, exprIsBig, 
+       exprIsConApp_maybe, 
+       hasNoRedexes,
 
--}  ) where
+       -- Arity and eta expansion
+       manifestArity, exprArity, 
+       exprEtaExpandArity, etaExpand, 
 
-IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop)        -- for pananoia-checking purposes
+       -- Size
+       coreBindsSize,
 
-import CoreSyn
+       -- Hashing
+       hashExpr,
 
-import CostCentre      ( isDictCC )
-import Id              ( idType, mkSysLocal, getIdArity, isBottomingId,
-                         toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
-                         addOneToIdEnv, growIdEnvList, lookupIdEnv,
-                         isNullIdEnv, SYN_IE(IdEnv),
-                         GenId{-instances-}
-                       )
-import IdInfo          ( arityMaybe )
-import Literal         ( literalType, isNoRepLit, Literal(..) )
-import Maybes          ( catMaybes, maybeToBool )
-import PprCore
-import PprStyle                ( PprStyle(..) )
-import PprType         ( GenType{-instances-} )
-import Pretty          ( ppAboves )
-import PrelVals                ( augmentId, buildId )
-import PrimOp          ( primOpType, fragilePrimOp, PrimOp(..) )
-import SrcLoc          ( mkUnknownSrcLoc )
-import TyVar           ( cloneTyVar,
-                         isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
-                       )
-import Type            ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
-                         getFunTy_maybe, applyTy, isPrimType,
-                         splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
+       -- Equality
+       cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
+    ) where
+
+#include "HsVersions.h"
+
+
+import GLAEXTS         -- For `xori` 
+
+import CoreSyn
+import PprCore         ( pprCoreExpr )
+import Var             ( Var, isId, isTyVar )
+import VarEnv
+import Name            ( hashName, isDllName )
+import Literal         ( hashLiteral, literalType, litIsDupable, 
+                         litIsTrivial, isZeroLit, isLitLitLit )
+import DataCon         ( DataCon, dataConRepArity, dataConArgTys,
+                         isExistentialDataCon, dataConTyCon, dataConName )
+import PrimOp          ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
+import Id              ( Id, idType, globalIdDetails, idNewStrictness, 
+                         mkWildId, idArity, idName, idUnfolding, idInfo,
+                         isOneShotLambda, isDataConWorkId_maybe, mkSysLocal,
+                         isDataConWorkId, isBottomingId
                        )
-import TysWiredIn      ( trueDataCon, falseDataCon )
-import UniqSupply      ( initUs, returnUs, thenUs,
-                         mapUs, mapAndUnzipUs, getUnique,
-                         SYN_IE(UniqSM), UniqSupply
+import IdInfo          ( GlobalIdDetails(..), megaSeqIdInfo )
+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 Usage           ( SYN_IE(UVar) )
-import Util            ( zipEqual, panic, pprPanic, assertPanic )
-
-type TypeEnv = TyVarEnv Type
-applyUsage = panic "CoreUtils.applyUsage:ToDo"
+import TyCon           ( tyConArity )
+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 )
+import TysPrim         ( statePrimTyCon )
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
 \subsection{Find the type of a Core atom/expression}
@@ -73,754 +82,1161 @@ applyUsage = panic "CoreUtils.applyUsage:ToDo"
 %************************************************************************
 
 \begin{code}
-coreExprType :: CoreExpr -> Type
-
-coreExprType (Var var) = idType   var
-coreExprType (Lit lit) = literalType lit
+exprType :: CoreExpr -> Type
+
+exprType (Var var)             = idType var
+exprType (Lit lit)             = literalType lit
+exprType (Let _ body)          = exprType body
+exprType (Case _ _ alts)        = coreAltsType alts
+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 e@(App _ _)
+  = case collectArgs e of
+       (fun, args) -> applyTypeToArgs e (exprType fun) args
+
+exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
+
+coreAltsType :: [CoreAlt] -> Type
+coreAltsType ((_,_,rhs) : _) = exprType rhs
+\end{code}
 
-coreExprType (Let _ body)      = coreExprType body
-coreExprType (SCC _ expr)      = coreExprType expr
-coreExprType (Case _ alts)     = coreAltsType alts
+@mkPiType@ makes a (->) type or a forall type, depending on whether
+it is given a type variable or a term variable.  We cleverly use the
+lbvarinfo field to figure out the right annotation for the arrove in
+case of a term variable.
 
-coreExprType (Coerce _ ty _)   = ty -- that's the whole point!
+\begin{code}
+mkPiType  :: Var   -> Type -> Type     -- The more polymorphic version
+mkPiTypes :: [Var] -> Type -> Type     --    doesn't work...
 
--- a Con is a fully-saturated application of a data constructor
--- a Prim is <ditto> of a PrimOp
+mkPiTypes vs ty = foldr mkPiType ty vs
 
-coreExprType (Con con args) = applyTypeToArgs (idType    con) args
-coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
+mkPiType v ty
+   | isId v    = mkFunTy (idType v) ty
+   | otherwise = mkForAllTy v ty
+\end{code}
 
-coreExprType (Lam (ValBinder binder) expr)
-  = idType binder `mkFunTy` coreExprType expr
+\begin{code}
+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
+    go [ty] args
+  where
+    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
+       Just (_, res_ty) -> applyTypeToArgs e res_ty args
+       Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
+\end{code}
 
-coreExprType (Lam (TyBinder tyvar) expr)
-  = mkForAllTy tyvar (coreExprType expr)
 
-coreExprType (Lam (UsageBinder uvar) expr)
-  = mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
 
-coreExprType (App expr (TyArg ty))
-  = applyTy (coreExprType expr) ty
+%************************************************************************
+%*                                                                     *
+\subsection{Attaching notes}
+%*                                                                     *
+%************************************************************************
 
-coreExprType (App expr (UsageArg use))
-  = applyUsage (coreExprType expr) use
+mkNote removes redundant coercions, and SCCs where possible
 
-coreExprType (App expr val_arg)
-  = ASSERT(isValArg val_arg)
-    let
-       fun_ty = coreExprType expr
-    in
-    case (getFunTy_maybe fun_ty) of
-         Just (_, result_ty) -> result_ty
-#ifdef DEBUG
-         Nothing -> pprPanic "coreExprType:\n"
-               (ppAboves [ppr PprDebug fun_ty,
-                          ppr PprShowAll (App expr val_arg)])
-#endif
+\begin{code}
+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
+
+-- Slide InlineCall in around the function
+--     No longer necessary I think (SLPJ Apr 99)
+-- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
+-- mkNote InlineCall (Var v)   = Note InlineCall (Var v)
+-- mkNote InlineCall expr      = expr
 \end{code}
 
+Drop trivial InlineMe's.  This is somewhat important, because if we have an unfolding
+that looks like        (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
+not be *applied* to anything.
+
+We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
+bindings like
+       fw = ...
+       f  = inline_me (coerce t fw)
+As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
+We want the split, so that the coerces can cancel at the call site.  
+
+However, we can get left with tiresome type applications.  Notably, consider
+       f = /\ a -> let t = e in (t, w)
+Then lifting the let out of the big lambda gives
+       t' = /\a -> e
+       f = /\ a -> let t = inline_me (t' a) in (t, w)
+The inline_me is to stop the simplifier inlining t' right back
+into t's RHS.  In the next phase we'll substitute for t (since
+its rhs is trivial) and *then* we could get rid of the inline_me.
+But it hardly seems worth it, so I don't bother.
+
 \begin{code}
-coreAltsType :: CoreCaseAlts -> Type
+mkInlineMe (Var v) = Var v
+mkInlineMe e      = Note InlineMe e
+\end{code}
 
-coreAltsType (AlgAlts [] deflt)         = default_ty deflt
-coreAltsType (AlgAlts ((_,_,rhs1):_) _) = coreExprType rhs1
 
-coreAltsType (PrimAlts [] deflt)       = default_ty deflt
-coreAltsType (PrimAlts ((_,rhs1):_) _) = coreExprType rhs1
 
-default_ty NoDefault           = panic "coreExprType:Case:default_ty"
-default_ty (BindDefault _ rhs) = coreExprType rhs
+\begin{code}
+mkCoerce :: Type -> CoreExpr -> CoreExpr
+mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
+
+mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
+mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
+  = ASSERT( from_ty `eqType` to_ty2 )
+    mkCoerce2 to_ty from_ty2 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
 \end{code}
 
 \begin{code}
-applyTypeToArgs op_ty args         = foldl applyTypeToArg op_ty args
-
-applyTypeToArg op_ty (TyArg ty)     = applyTy op_ty ty
-applyTypeToArg op_ty (UsageArg _)   = panic "applyTypeToArg: UsageArg"
-applyTypeToArg op_ty val_or_lit_arg = case (getFunTy_maybe op_ty) of
-                                       Just (_, res_ty) -> res_ty
+mkSCC :: CostCentre -> Expr b -> Expr b
+       -- Note: Nested SCC's *are* preserved for the benefit of
+       --       cost centre stack profiling
+mkSCC cc (Lit lit)         = Lit lit
+mkSCC cc (Lam x e)         = Lam x (mkSCC cc e)  -- Move _scc_ inside lambda
+mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
+mkSCC cc (Note n e)        = Note n (mkSCC cc e) -- Move _scc_ inside notes
+mkSCC cc expr              = Note (SCC cc) expr
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
-\subsection{Routines to manufacture bits of @CoreExpr@}
+\subsection{Other expression construction}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
-mkCoreIfThenElse (Var bool) then_expr else_expr
-    | bool == trueDataCon   = then_expr
-    | bool == falseDataCon  = else_expr
-
-mkCoreIfThenElse guard then_expr else_expr
-  = Case guard
-      (AlgAlts [ (trueDataCon,  [], then_expr),
-                (falseDataCon, [], else_expr) ]
-       NoDefault )
+bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
+-- (bindNonRec x r b) produces either
+--     let x = r in b
+-- or
+--     case r of x { _DEFAULT_ -> b }
+--
+-- depending on whether x is unlifted or not
+-- 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)]
+  | 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}
 
-For making @Apps@ and @Lets@, we must take appropriate evasive
-action if the thing being bound has unboxed type.  @mkCoApp@ requires
-a name supply to do its work.
+\begin{code}
+mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
+       -- This guy constructs the value that the scrutinee must have
+       -- when you are in one particular branch of a case
+mkAltExpr (DataAlt con) args inst_tys
+  = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
+mkAltExpr (LitAlt lit) [] []
+  = Lit lit
+
+mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
+mkIfThenElse guard then_expr else_expr
+  = Case guard (mkWildId boolTy) 
+        [ (DataAlt trueDataCon,  [], then_expr),
+          (DataAlt falseDataCon, [], else_expr) ]
+\end{code}
 
-@mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
-arguments-must-be-atoms constraint.
 
-\begin{code}
-data CoreArgOrExpr
-  = AnArg   CoreArg
-  | AnExpr  CoreExpr
+%************************************************************************
+%*                                                                     *
+\subsection{Taking expressions apart}
+%*                                                                     *
+%************************************************************************
 
-mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
-mkCoCon  :: Id       -> [CoreArgOrExpr] -> UniqSM CoreExpr
-mkCoPrim :: PrimOp   -> [CoreArgOrExpr] -> UniqSM CoreExpr
+The default alternative must be first, if it exists at all.
+This makes it easy to find, though it makes matching marginally harder.
 
-mkCoApps fun args = co_thing (mkGenApp fun) args
-mkCoCon  con args = co_thing (Con  con)     args
-mkCoPrim  op args = co_thing (Prim op)      args 
+\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)
 
-co_thing :: ([CoreArg] -> CoreExpr)
-        -> [CoreArgOrExpr]
-        -> UniqSM CoreExpr
+findAlt :: AltCon -> [CoreAlt] -> CoreAlt
+findAlt con alts
+  = case alts of
+       (deflt@(DEFAULT,_,_):alts) -> go alts deflt
+       other                      -> go alts panic_deflt
 
-co_thing thing arg_exprs
-  = mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
-    returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
   where
-    expr_to_arg :: CoreArgOrExpr
-               -> UniqSM (CoreArg, Maybe CoreBinding)
-
-    expr_to_arg (AnArg  arg)     = returnUs (arg,      Nothing)
-    expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
-    expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
-    expr_to_arg (AnExpr other_expr)
-      = let
-           e_ty = coreExprType other_expr
-       in
-       getUnique `thenUs` \ uniq ->
-       let
-           new_var  = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
-       in
-       returnUs (VarArg new_var, Just (NonRec new_var other_expr))
+    panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
+
+    go []                     deflt               = deflt
+    go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
+                                    | otherwise   = ASSERT( not (con1 == DEFAULT) )
+                                                    go alts deflt
 \end{code}
 
-\begin{code}
-argToExpr ::
-  GenCoreArg val_occ tyvar uvar -> GenCoreExpr val_bdr val_occ tyvar uvar
 
-argToExpr (VarArg v)   = Var v
-argToExpr (LitArg lit) = Lit lit
-\end{code}
+%************************************************************************
+%*                                                                     *
+\subsection{Figuring out things about expressions}
+%*                                                                     *
+%************************************************************************
 
-\begin{code}
-exprSmallEnoughToDup (Con _ _)   = True        -- Could check # of args
-exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
-exprSmallEnoughToDup (Lit lit)   = not (isNoRepLit lit)
-exprSmallEnoughToDup expr
-  = case (collectArgs expr) of { (fun, _, _, vargs) ->
-    case fun of
-      Var v | length vargs == 0 -> True
-      _                                -> False
-    }
-
-{- LATER:
-WAS: MORE CLEVER:
-exprSmallEnoughToDup expr  -- for now, just: <var> applied to <args>
-  = case (collectArgs expr) of { (fun, _, _, vargs) ->
-    case fun of
-      Var v -> v /= buildId
-                && v /= augmentId
-                && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish.
-      _       -> False
-    }
--}
-\end{code}
-Question (ADR): What is the above used for?  Is a _ccall_ really small
-enough?
+@exprIsTrivial@ is true of expressions we are unconditionally happy to
+               duplicate; simple variables and constants, and type
+               applications.  Note that primop Ids aren't considered
+               trivial unless 
 
-@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
-it is obviously in weak head normal form.  It isn't a disaster if it
-errs on the conservative side (returning \tr{False})---I've probably
-left something out... [WDP]
+@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}
-manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool
-
-manifestlyWHNF (Var _)       = True
-manifestlyWHNF (Lit _)       = True
-manifestlyWHNF (Con _ _)      = True
-manifestlyWHNF (SCC _ e)      = manifestlyWHNF e
-manifestlyWHNF (Coerce _ _ e) = manifestlyWHNF e
-manifestlyWHNF (Let _ e)      = False
-manifestlyWHNF (Case _ _)     = False
-
-manifestlyWHNF (Lam x e)  = if isValBinder x then True else manifestlyWHNF e
-
-manifestlyWHNF other_expr   -- look for manifest partial application
-  = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
-    case fun of
-      Var f ->  let
-                   num_val_args = length vargs
-               in
-               num_val_args == 0 -- Just a type application of
-                                 -- a variable (f t1 t2 t3);
-                                 -- counts as WHNF.
-               ||
-               case (arityMaybe (getIdArity f)) of
-                 Nothing     -> False
-                 Just arity  -> num_val_args < arity
-
-      _ -> 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 _ e)   = exprIsTrivial e
+exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
+exprIsTrivial other       = False
 \end{code}
 
-@manifestlyBottom@ looks at a Core expression and returns \tr{True} if
-it is obviously bottom, that is, it will certainly return bottom at
-some point.  It isn't a disaster if it errs on the conservative side
-(returning \tr{False}).
+
+@exprIsDupable@        is true of expressions that can be duplicated at a modest
+               cost in code size.  This will only happen in different case
+               branches, so there's no issue about duplicating work.
+
+               That is, exprIsDupable returns True of (f x) even if
+               f is very very expensive to call.
+
+               Its only purpose is to avoid fruitless let-binding
+               and then inlining of case join points
+
 
 \begin{code}
-manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
-
-manifestlyBottom (Var v)       = isBottomingId v
-manifestlyBottom (Lit _)       = False
-manifestlyBottom (Con  _ _)    = False
-manifestlyBottom (Prim _ _)    = False
-manifestlyBottom (SCC _ e)     = manifestlyBottom e
-manifestlyBottom (Coerce _ _ e) = manifestlyBottom e
-manifestlyBottom (Let _ e)     = manifestlyBottom e
-
-  -- We do not assume \x.bottom == bottom:
-manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e
-
-manifestlyBottom (Case e a)
-  = manifestlyBottom e
-  || (case a of
-       AlgAlts  alts def -> all mbalg  alts && mbdef def
-       PrimAlts alts def -> all mbprim alts && mbdef def
-     )
+exprIsDupable (Type _)         = True
+exprIsDupable (Var v)          = True
+exprIsDupable (Lit lit)        = litIsDupable lit
+exprIsDupable (Note InlineMe e) = True
+exprIsDupable (Note _ e)        = exprIsDupable e
+exprIsDupable expr          
+  = go expr 0
   where
-    mbalg  (_,_,e') = manifestlyBottom e'
-
-    mbprim (_,e')   = manifestlyBottom e'
-
-    mbdef NoDefault          = True
-    mbdef (BindDefault _ e') = manifestlyBottom e'
-
-manifestlyBottom other_expr   -- look for manifest partial application
-  = case (collectArgs other_expr) of { (fun, _, _, _) ->
-    case fun of
-      Var f | isBottomingId f -> True
-               -- Application of a function which always gives
-               -- bottom; we treat this as a WHNF, because it
-               -- certainly doesn't need to be shared!
-      _ -> False
-    }
+    go (Var v)   n_args = True
+    go (App f a) n_args =  n_args < dupAppSize
+                       && exprIsDupable a
+                       && go f (n_args+1)
+    go other n_args    = False
+
+dupAppSize :: Int
+dupAppSize = 4         -- Size of application we are prepared to duplicate
 \end{code}
 
-\begin{code}
-{-LATER:
-coreExprArity
-       :: (Id -> Maybe (GenCoreExpr bndr Id))
-       -> GenCoreExpr bndr Id
-       -> Int
-coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
-coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
-coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
-coreExprArity f (CoTyApp expr _) = coreExprArity f expr
-coreExprArity f (Var v) = max further info
-   where
-       further
-            = case f v of
-               Nothing -> 0
-               Just expr -> coreExprArity f expr
-       info = case (arityMaybe (getIdArity v)) of
-               Nothing    -> 0
-               Just arity -> arity
-coreExprArity f _ = 0
-\end{code}
+@exprIsCheap@ looks at a Core expression and returns \tr{True} if
+it is obviously in weak head normal form, or is cheap to get to WHNF.
+[Note that that's not the same as exprIsDupable; an expression might be
+big, and hence not dupable, but still cheap.]
 
-@isWrapperFor@: we want to see exactly:
-\begin{verbatim}
-/\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
-\end{verbatim}
+By ``cheap'' we mean a computation we're willing to:
+       push inside a lambda, or
+       inline at more than one place
+That might mean it gets evaluated more than once, instead of being
+shared.  The main examples of things which aren't WHNF but are
+``cheap'' are:
 
-Probably a little too HACKY [WDP].
+  *    case e of
+         pi -> ei
+       (where e, and all the ei are cheap)
 
-\begin{code}
-isWrapperFor :: CoreExpr -> Id -> Bool
+  *    let x = e in b
+       (where e and b are cheap)
+
+  *    op x1 ... xn
+       (where op is a cheap primitive operator)
+
+  *    error "foo"
+       (because we are happy to substitute it inside a lambda)
+
+Notice that a variable is considered 'cheap': we can push it inside a lambda,
+because sharing will make sure it is only evaluated once.
 
-expr `isWrapperFor` var
-  = case (collectBinders  expr) of { (_, _, args, body) -> -- lambdas off the front
-    unravel_casing args body
-    --NO, THANKS: && not (null args)
-    }
+\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 && 
+                                   and [exprIsCheap rhs | (_,_,rhs) <- alts]
+       -- Experimentally, treat (case x of ...) as cheap
+       -- (and case __coerce x etc.)
+       -- This improves arities of overloaded functions where
+       -- there is only dictionary selection (no construction) involved
+exprIsCheap (Let (NonRec x _) e)  
+      | isUnLiftedType (idType x) = exprIsCheap e
+      | otherwise                = False
+       -- strict lets always have cheap right hand sides, and
+       -- do no allocation.
+
+exprIsCheap other_expr 
+  = go other_expr 0 True
   where
-    var's_worker = getWorkerId (getIdStrictness var)
-
-    is_elem = isIn "isWrapperFor"
-
-    --------------
-    unravel_casing case_ables (Case scrut alts)
-      = case (collectArgs scrut) of { (fun, _, _, vargs) ->
-       case fun of
-         Var scrut_var -> let
-                               answer =
-                                    scrut_var /= var && all (doesn't_mention var) vargs
-                                 && scrut_var `is_elem` case_ables
-                                 && unravel_alts case_ables alts
-                            in
-                            answer
-
-         _ -> False
-       }
+    go (Var f) n_args args_cheap 
+       = (idAppIsCheap f n_args && args_cheap)
+                       -- A constructor, cheap primop, or partial application
+
+         || idAppIsBottom f n_args 
+                       -- Application of a function which
+                       -- always gives bottom; we treat this as cheap
+                       -- because it certainly doesn't need to be shared!
+       
+    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)
+
+    go other   n_args args_cheap = False
+
+idAppIsCheap :: Id -> Int -> Bool
+idAppIsCheap id n_val_args 
+  | n_val_args == 0 = True     -- Just a type application of
+                               -- a variable (f t1 t2 t3)
+                               -- counts as WHNF
+  | otherwise = case globalIdDetails id of
+                 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
+                                                       -- might be applied to something, but I'm not going
+                                                       -- to bother to check the number of args
+                 other       -> n_val_args < idArity id
+\end{code}
 
-    unravel_casing case_ables other_expr
-      = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
-       case fun of
-         Var wrkr -> let
-                           answer =
-                               -- DOESN'T WORK: wrkr == var's_worker
-                               wrkr /= var
-                            && isWorkerId wrkr
-                            && all (doesn't_mention var)  vargs
-                            && all (only_from case_ables) vargs
-                       in
-                       answer
-
-         _ -> False
-       }
+exprOkForSpeculation returns True of an expression that it is
 
-    --------------
-    unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
-      = unravel_casing (params ++ case_ables) rhs
-    unravel_alts case_ables other = False
+       * safe to evaluate even if normal order eval might not 
+         evaluate the expression at all, or
 
-    -------------------------
-    doesn't_mention var (ValArg (VarArg v)) = v /= var
-    doesn't_mention var other = True
+       * safe *not* to evaluate even if normal order would do so
 
-    -------------------------
-    only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
-    only_from case_ables other = True
--}
-\end{code}
+It returns True iff
 
-All the following functions operate on binders, perform a uniform
-transformation on them; ie. the function @(\ x -> (x,False))@
-annotates all binders with False.
+       the expression guarantees to terminate, 
+       soon, 
+       without raising an exception,
+       without causing a side effect (e.g. writing a mutable variable)
 
-\begin{code}
-unTagBinders :: GenCoreExpr (Id,tag) bdee tv uv -> GenCoreExpr Id bdee tv uv
-unTagBinders expr = bop_expr fst expr
+E.G.
+       let x = case y# +# 1# of { r# -> I# r# }
+       in E
+==>
+       case y# +# 1# of { r# -> 
+       let x = I# r#
+       in E 
+       }
+
+We can only do this if the (y+1) is ok for speculation: it has no
+side effects, and can't diverge or raise an exception.
 
-unTagBindersAlts :: GenCoreCaseAlts (Id,tag) bdee tv uv -> GenCoreCaseAlts Id bdee tv uv
-unTagBindersAlts alts = bop_alts fst alts
+\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
+  = case collectArgs other_expr of
+       (Var f, args) -> spec_ok (globalIdDetails f) args
+       other         -> False
+  where
+    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
+
+    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}
 
+
 \begin{code}
-bop_expr  :: (a -> b) -> GenCoreExpr a bdee tv uv -> GenCoreExpr b bdee tv uv
-
-bop_expr f (Var b)          = Var b
-bop_expr f (Lit lit)        = Lit lit
-bop_expr f (Con con args)    = Con con args
-bop_expr f (Prim op args)    = Prim op args
-bop_expr f (Lam binder expr) = Lam  (bop_binder f binder) (bop_expr f expr)
-bop_expr f (App expr arg)    = App  (bop_expr f expr) arg
-bop_expr f (SCC label expr)  = SCC  label (bop_expr f expr)
-bop_expr f (Coerce c ty e)   = Coerce c ty (bop_expr f e)
-bop_expr f (Let bind expr)   = Let  (bop_bind f bind) (bop_expr f expr)
-bop_expr f (Case expr alts)  = Case (bop_expr f expr) (bop_alts f alts)
-
-bop_binder f (ValBinder   v) = ValBinder (f v)
-bop_binder f (TyBinder    t) = TyBinder    t
-bop_binder f (UsageBinder u) = UsageBinder u
-
-bop_bind f (NonRec b e)        = NonRec (f b) (bop_expr f e)
-bop_bind f (Rec pairs) = Rec [(f b, bop_expr f e) | (b, e) <- pairs]
-
-bop_alts f (AlgAlts alts deflt)
-  = AlgAlts  [ (con, [f b | b <- binders], bop_expr f e)
-            | (con, binders, e) <- alts ]
-            (bop_deflt f deflt)
-
-bop_alts f (PrimAlts alts deflt)
-  = PrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
-            (bop_deflt f deflt)
-
-bop_deflt f (NoDefault)                 = NoDefault
-bop_deflt f (BindDefault b expr) = BindDefault (f b) (bop_expr f expr)
+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
+
+idAppIsBottom :: Id -> Int -> Bool
+idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
 \end{code}
 
-OLD (but left here because of the nice example): @singleAlt@ checks
-whether a bunch of case alternatives is actually just one alternative.
-It specifically {\em ignores} alternatives which consist of just a
-call to @error@, because they won't result in any code duplication.
+@exprIsValue@ returns true for expressions that are certainly *already* 
+evaluated to *head* normal form.  This is used to decide whether it's ok 
+to change
 
-Example:
-\begin{verbatim}
-       case (case <something> of
-               True  -> <rhs>
-               False -> error "Foo") of
-       <alts>
+       case x of _ -> e   ===>   e
 
-===>
+and to decide whether it's safe to discard a `seq`
 
-       case <something> of
-          True ->  case <rhs> of
-                   <alts>
-          False -> case error "Foo" of
-                   <alts>
+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, 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
 
-       case <something> of
-          True ->  case <rhs> of
-                   <alts>
-          False -> error "Foo"
-\end{verbatim}
-Notice that the \tr{<alts>} don't get duplicated.
+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
+type must be ok-for-speculation (or trivial).
 
 \begin{code}
-nonErrorRHSs :: GenCoreCaseAlts a Id TyVar UVar -> [GenCoreExpr a Id TyVar UVar]
-
-nonErrorRHSs alts
-  = filter not_error_app (find_rhss alts)
+exprIsValue :: CoreExpr -> Bool                -- True => Value-lambda, constructor, PAP
+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 (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
-    find_rhss (AlgAlts  as deflt) = [rhs | (_,_,rhs) <- as] ++ deflt_rhs deflt
-    find_rhss (PrimAlts as deflt) = [rhs | (_,rhs)   <- as] ++ deflt_rhs deflt
-
-    deflt_rhs NoDefault           = []
-    deflt_rhs (BindDefault _ rhs) = [rhs]
-
-    not_error_app rhs
-      = case (maybeErrorApp rhs Nothing) of
-         Just _  -> False
-         Nothing -> True
+    (arg_ty, res_ty) = splitFunTy fun_ty
 \end{code}
 
-maybeErrorApp checks whether an expression is of the form
-
-       error ty args
+\begin{code}
+exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
+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 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
+    --
+    -- 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 <- isDataConWorkId_maybe fun,
+         args `lengthAtLeast` dataConRepArity con
+               -- Might be > because the arity excludes type args
+       = Just (con,args)
+
+       -- Look through unfoldings, but only cheap ones, because
+       -- we are effectively duplicating the unfolding
+    analyse (Var fun, [])
+       | let unf = idUnfolding fun,
+         isCheapUnfolding unf
+       = exprIsConApp_maybe (unfoldingTemplate unf)
+
+    analyse other = Nothing
+\end{code}
 
-If so, it returns
 
-       Just (error ty' args)
 
-where ty' is supplied as an argument to maybeErrorApp.
+%************************************************************************
+%*                                                                     *
+\subsection{Eta reduction and expansion}
+%*                                                                     *
+%************************************************************************
 
-Here's where it is useful:
+\begin{code}
+exprEtaExpandArity :: CoreExpr -> Arity
+{- 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.isOneShotLambda.
+
+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.
+-}
 
-               case (error ty "Foo" e1 e2) of <alts>
- ===>
-               error ty' "Foo"
 
-where ty' is the type of any of the alternatives.  You might think
-this never occurs, but see the comments on the definition of
-@singleAlt@.
+exprEtaExpandArity e = arityDepth (arityType e)
 
-Note: we *avoid* the case where ty' might end up as a primitive type:
-this is very uncool (totally wrong).
+-- A limited sort of function type
+data ArityType = AFun Bool ArityType   -- True <=> one-shot
+              | ATop                   -- Know nothing
+              | ABot                   -- Diverges
 
-NOTICE: in the example above we threw away e1 and e2, but not the
-string "Foo".  How did we know to do that?
+arityDepth :: ArityType -> Arity
+arityDepth (AFun _ ty) = 1 + arityDepth ty
+arityDepth ty         = 0
 
-Answer: for now anyway, we only handle the case of a function whose
-type is of form
+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
 
-       bottomingFn :: forall a. t1 -> ... -> tn -> a
-                             ^---------------------^ NB!
+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
 
-Furthermore, we only count a bottomingApp if the function is applied
-to more than n args.  If so, we transform:
+arityType (Note n e) = arityType e
+--     Not needed any more: etaExpand is cleverer
+--  | ok_note n = arityType e
+--  | otherwise = ATop
 
-       bottomingFn ty e1 ... en en+1 ... em
-to
-       bottomingFn ty' e1 ... en
+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
+arityType (Lam x e) | isId x    = AFun (isOneShotLambda x || isStateHack 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 | 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
+                                 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
+
+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
+    -- 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}
 
-That is, we discard en+1 .. em
 
 \begin{code}
-maybeErrorApp
-       :: GenCoreExpr a Id TyVar UVar  -- Expr to look at
-       -> Maybe Type                   -- Just ty => a result type *already cloned*;
-                                       -- Nothing => don't know result ty; we
-                                       -- *pretend* that the result ty won't be
-                                       -- primitive -- somebody later must
-                                       -- ensure this.
-       -> Maybe (GenCoreExpr a Id TyVar UVar)
-
-maybeErrorApp expr result_ty_maybe
-  = case (collectArgs expr) of
-      (Var fun, [{-no usage???-}], [ty], other_args)
-       | isBottomingId fun
-       && maybeToBool result_ty_maybe -- we *know* the result type
-                                      -- (otherwise: live a fairy-tale existence...)
-       && not (isPrimType result_ty) ->
-
-       case (splitSigmaTy (idType fun)) of
-         ([tyvar], [], tau_ty) ->
-             case (splitFunTy tau_ty) of { (arg_tys, res_ty) ->
-             let
-                 n_args_to_keep = length arg_tys
-                 args_to_keep   = take n_args_to_keep other_args
-             in
-             if  (res_ty `eqTy` mkTyVarTy tyvar)
-              && n_args_to_keep <= length other_args
-             then
-                   -- Phew!  We're in business
-                 Just (mkGenApp (Var fun) (TyArg result_ty : args_to_keep))
-             else
-                 Nothing
-             }
-
-         other -> Nothing  -- Function type wrong shape
-      other -> Nothing
+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'.  
+--
+-- 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
+  | otherwise              = eta_expand n us expr ty
   where
-    Just result_ty = result_ty_maybe
+
+-- 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
+-- where  E :: forall a. a -> a
+-- would return
+--     (/\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
+
+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 
+    -- may be.  So we eagerly eta expand any big lambdas, and just
+    -- 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)        
+    -- Saturated, so nothing to do
+  = expr
+
+       -- 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))
+
+-- 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')
+
+       ; Nothing ->
+  
+       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 FSLIT("eta") uniq arg_ty
+                                  (uniq:us2) = us
+                                  
+       ; Nothing ->
+
+               -- Given this:
+               --      newtype T = MkT (Int -> Int)
+               -- Consider eta-expanding this
+               --      eta_expand 1 e T
+               -- We want to get
+               --      coerce T (\x::Int -> (coerce (Int->Int) e) x)
+
+       case splitNewType_maybe ty of {
+         Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
+         Nothing  -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
+       }}}
 \end{code}
 
-\begin{code}
-squashableDictishCcExpr :: CostCentre -> GenCoreExpr a b c d -> Bool
+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
+exprEtaExpandArity will do the hard work, leaving something that's easy
+for exprArity to grapple with.  In particular, Simplify uses exprArity to
+compute the ArityInfo for the Id. 
 
-squashableDictishCcExpr cc expr
-  = if not (isDictCC cc) then
-       False -- that was easy...
-    else
-       squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
-  where
-    squashable (Var _)      = True
-    squashable (Con  _ _)   = True -- I think so... WDP 94/09
-    squashable (Prim _ _)   = True -- ditto
-    squashable (App f a)
-      | notValArg a        = squashable f
-    squashable other       = False
+Originally I thought that it was enough just to look for top-level lambdas, but
+it isn't.  I've seen this
+
+       foo = PrelBase.timesInt
+
+We want foo to get arity 2 even though the eta-expander will leave it
+unchanged, in the expectation that it'll be inlined.  But occasionally it
+isn't, because foo is blacklisted (used in a rule).  
+
+Similarly, see the ok_note check in exprEtaExpandArity.  So 
+       f = __inline_me (\x -> e)
+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}
+exprArity :: CoreExpr -> Arity
+exprArity e = go e
+           where
+             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}
 
 %************************************************************************
 %*                                                                     *
-\subsection{Core-renaming utils}
+\subsection{Equality}
 %*                                                                     *
 %************************************************************************
 
-\begin{code}
-substCoreBindings :: ValEnv
-               -> TypeEnv -- TyVar=>Type
-               -> [CoreBinding]
-               -> UniqSM [CoreBinding]
-
-substCoreExpr  :: ValEnv
-               -> TypeEnv -- TyVar=>Type
-               -> CoreExpr
-               -> UniqSM CoreExpr
-
-substCoreBindings venv tenv binds
-  -- if the envs are empty, then avoid doing anything
-  = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
-       returnUs binds
-    else
-       do_CoreBindings venv tenv binds
-
-substCoreExpr venv tenv expr
-  = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
-       returnUs expr
-    else
-       do_CoreExpr venv tenv expr
-\end{code}
+@cheapEqExpr@ is a cheap equality test which bales out fast!
+       True  => definitely equal
+       False => may or may not be equal
 
-The equiv code for @Types@ is in @TyUtils@.
+\begin{code}
+cheapEqExpr :: Expr b -> Expr b -> Bool
 
-Because binders aren't necessarily unique: we don't do @plusEnvs@
-(which check for duplicates); rather, we use the shadowing version,
-@growIdEnv@ (and shorthand @addOneToIdEnv@).
+cheapEqExpr (Var v1)   (Var v2)   = v1==v2
+cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
+cheapEqExpr (Type t1)  (Type t2)  = t1 `eqType` t2
 
-@do_CoreBindings@ takes into account the semantics of a list of
-@CoreBindings@---things defined early in the list are visible later in
-the list, but not vice versa.
+cheapEqExpr (App f1 a1) (App f2 a2)
+  = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 
-\begin{code}
-type ValEnv  = IdEnv CoreExpr
+cheapEqExpr _ _ = False
 
-do_CoreBindings :: ValEnv
-               -> TypeEnv
-               -> [CoreBinding]
-               -> UniqSM [CoreBinding]
+exprIsBig :: Expr b -> Bool
+-- Returns True of expressions that are too big to be compared by cheapEqExpr
+exprIsBig (Lit _)      = False
+exprIsBig (Var v)      = False
+exprIsBig (Type t)     = False
+exprIsBig (App f a)    = exprIsBig f || exprIsBig a
+exprIsBig other               = True
+\end{code}
 
-do_CoreBinding :: ValEnv
-              -> TypeEnv
-              -> CoreBinding
-              -> UniqSM (CoreBinding, ValEnv)
 
-do_CoreBindings venv tenv [] = returnUs []
-do_CoreBindings venv tenv (b:bs)
-  = do_CoreBinding  venv     tenv b    `thenUs` \ (new_b,  new_venv) ->
-    do_CoreBindings new_venv tenv bs   `thenUs` \  new_bs ->
-    returnUs (new_b : new_bs)
+\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
+  -- The "env" maps variables in e1 to variables in ty2
+  -- So when comparing lambdas etc, 
+  -- we in effect substitute v2 for v1 in e1 before continuing
+    eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
+                                 Just v1' -> v1' == v2
+                                 Nothing  -> v1  == v2
+
+    eq env (Lit lit1)   (Lit lit2)   = lit1 == lit2
+    eq env (App f1 a1)  (App f2 a2)  = eq env f1 f2 && eq env a1 a2
+    eq env (Lam v1 e1)  (Lam v2 e2)  = eq (extendVarEnv env v1 v2) 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)        = 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 &&
+                                      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
+    eq env (Type t1)    (Type t2)    = t1 `eqType` t2
+    eq env e1          e2           = False
+                                        
+    eq_list env []      []       = True
+    eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
+    eq_list env es1      es2      = False
+    
+    eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
+                                        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 `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}
 
-do_CoreBinding venv tenv (NonRec binder rhs)
-  = do_CoreExpr venv tenv rhs  `thenUs` \ new_rhs ->
 
-    dup_binder tenv binder     `thenUs` \ (new_binder, (old, new)) ->
-    -- now plug new bindings into envs
-    let  new_venv = addOneToIdEnv venv old new  in
+%************************************************************************
+%*                                                                     *
+\subsection{The size of an expression}
+%*                                                                     *
+%************************************************************************
 
-    returnUs (NonRec new_binder new_rhs, new_venv)
+\begin{code}
+coreBindsSize :: [CoreBind] -> Int
+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)       = 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
+
+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
+          | otherwise = seqType (idType b)             `seq`
+                        megaSeqIdInfo (idInfo b)       `seq`
+                        1
+
+varsSize = foldr ((+) . varSize) 0
+
+bindSize (NonRec b e) = varSize b + exprSize e
+bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
+
+pairSize (b,e) = varSize b + exprSize e
+
+altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
+\end{code}
 
-do_CoreBinding venv tenv (Rec binds)
-  = -- for letrec, we plug in new bindings BEFORE cloning rhss
-    mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
-    let  new_venv = growIdEnvList venv new_maps in
 
-    mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
-    returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
-  where
-    (binders, rhss) = unzip binds
-\end{code}
+%************************************************************************
+%*                                                                     *
+\subsection{Hashing}
+%*                                                                     *
+%************************************************************************
 
 \begin{code}
-do_CoreArg :: ValEnv
-           -> TypeEnv
-           -> CoreArg
-           -> UniqSM CoreArgOrExpr
-
-do_CoreArg venv tenv a@(VarArg v)
-  = returnUs (
-      case (lookupIdEnv venv v) of
-       Nothing   -> AnArg  a
-       Just expr -> AnExpr expr
-    )
-
-do_CoreArg venv tenv (TyArg ty)
-  = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
-
-do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
+hashExpr :: CoreExpr -> Int
+hashExpr e | hash < 0  = 77    -- Just in case we hit -maxInt
+          | otherwise = hash
+          where
+            hash = abs (hash_expr e)   -- Negative numbers kill UniqFM
+
+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
+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 (Lam b _)              = hashId b
+hash_expr (Type t)               = trace "hash_expr: type" 1           -- Shouldn't happen
+
+fast_hash_expr (Var v)         = hashId v
+fast_hash_expr (Lit lit)       = hashLiteral lit
+fast_hash_expr (App f (Type _)) = fast_hash_expr f
+fast_hash_expr (App f a)        = fast_hash_expr a
+fast_hash_expr (Lam b _)        = hashId b
+fast_hash_expr other           = 1
+
+hashId :: Id -> Int
+hashId id = hashName (idName id)
 \end{code}
 
-\begin{code}
-do_CoreExpr :: ValEnv
-           -> TypeEnv
-           -> CoreExpr
-           -> UniqSM CoreExpr
-
-do_CoreExpr venv tenv orig_expr@(Var var)
-  = returnUs (
-      case (lookupIdEnv venv var) of
-       Nothing     -> --false:ASSERT(toplevelishId var) (SIGH)
-                      orig_expr
-       Just expr   -> expr
-    )
-
-do_CoreExpr venv tenv e@(Lit _) = returnUs e
-
-do_CoreExpr venv tenv (Con con as)
-  = mapUs  (do_CoreArg venv tenv) as `thenUs`  \ new_as ->
-    mkCoCon con new_as
-
-do_CoreExpr venv tenv (Prim op as)
-  = mapUs  (do_CoreArg venv tenv) as   `thenUs`  \ new_as ->
-    do_PrimOp op                       `thenUs`  \ new_op ->
-    mkCoPrim new_op new_as
-  where
-    do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
-      = let
-           new_arg_tys   = map (applyTypeEnvToTy tenv) arg_tys
-           new_result_ty = applyTypeEnvToTy tenv result_ty
-       in
-       returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
-
-    do_PrimOp other_op = returnUs other_op
-
-do_CoreExpr venv tenv (Lam (ValBinder binder) expr)
-  = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
-    let  new_venv = addOneToIdEnv venv old new  in
-    do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
-    returnUs (Lam (ValBinder new_binder) new_expr)
-
-do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr)
-  = dup_tyvar tyvar       `thenUs` \ (new_tyvar, (old, new)) ->
-    let
-       new_tenv = addOneToTyVarEnv tenv old new
-    in
-    do_CoreExpr venv new_tenv expr  `thenUs` \ new_expr ->
-    returnUs (Lam (TyBinder new_tyvar) new_expr)
+%************************************************************************
+%*                                                                     *
+\subsection{Determining non-updatable right-hand-sides}
+%*                                                                     *
+%************************************************************************
 
-do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder"
+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).
 
-do_CoreExpr venv tenv (App expr arg)
-  = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
-    do_CoreArg  venv tenv arg   `thenUs` \ new_arg  ->
-    mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
+If this happens we simply make the RHS into an updatable thunk, 
+and 'exectute' it rather than allocating it statically.
 
-do_CoreExpr venv tenv (Case expr alts)
-  = do_CoreExpr venv tenv expr     `thenUs` \ new_expr ->
-    do_alts venv tenv alts         `thenUs` \ new_alts ->
-    returnUs (Case new_expr new_alts)
+\begin{code}
+hasNoRedexes :: CoreExpr -> Bool
+-- This function is called only on *top-level* right-hand sides
+-- Returns True if 
+--     the expression contains any redex that 
+--     is not under a (value) lambda
+-- and
+--     it contains no cross-DLL references
+--
+-- The real reason: either
+--     a) the rhs *is* a redex, in which case it's a CAF
+--        (remember the arg is always a top-level rhs)
+-- or   b) the nested redex will ultimately be floated by CorePrep
+--        and will be a CAF, so this rhs *refers* to a CAF
+--
+-- 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.  In case (ii), the ANF-ising of CorePrep means that
+-- (b) cannot be the case, so it must be (a)!
+--
+-- NB: 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 non-redexes
+-- are saturated applications of constructors
+--
+--
+--     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).
+--
+hasNoRedexes (Lam b e)        = isRuntimeVar b || hasNoRedexes e
+hasNoRedexes (Note (SCC _) e) = False
+hasNoRedexes (Note _ e)       = hasNoRedexes e
+hasNoRedexes (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).
+hasNoRedexes other_expr              = go other_expr 0
   where
-    do_alts venv tenv (AlgAlts alts deflt)
-      = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
-       do_default venv tenv deflt          `thenUs` \ new_deflt ->
-       returnUs (AlgAlts new_alts new_deflt)
-      where
-       do_boxed_alt venv tenv (con, binders, expr)
-         = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
-           let  new_venv = growIdEnvList venv new_vmaps  in
-           do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
-           returnUs (con, new_binders, new_expr)
-
-
-    do_alts venv tenv (PrimAlts alts deflt)
-      = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
-       do_default venv tenv deflt            `thenUs` \ new_deflt ->
-       returnUs (PrimAlts new_alts new_deflt)
-      where
-       do_unboxed_alt venv tenv (lit, expr)
-         = do_CoreExpr venv tenv expr  `thenUs` \ new_expr ->
-           returnUs (lit, new_expr)
-
-    do_default venv tenv NoDefault = returnUs NoDefault
-
-    do_default venv tenv (BindDefault binder expr)
-      =        dup_binder tenv binder          `thenUs` \ (new_binder, (old, new)) ->
-       let  new_venv = addOneToIdEnv venv old new  in
-       do_CoreExpr new_venv tenv expr  `thenUs` \ new_expr ->
-       returnUs (BindDefault new_binder new_expr)
-
-do_CoreExpr venv tenv (Let core_bind expr)
-  = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
-    -- and do the body of the let
-    do_CoreExpr new_venv tenv expr     `thenUs` \ new_expr ->
-    returnUs (Let new_bind new_expr)
-
-do_CoreExpr venv tenv (SCC label expr)
-  = do_CoreExpr venv tenv expr         `thenUs` \ new_expr ->
-    returnUs (SCC label new_expr)
-
-do_CoreExpr venv tenv (Coerce c ty expr)
-  = do_CoreExpr venv tenv expr         `thenUs` \ new_expr ->
-    returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
+    go (Var f) n_val_args
+       | not (isDllName (idName f))
+       = n_val_args == 0 || saturated_data_con f n_val_args
+
+    go (App f a) n_val_args
+       | isTypeArg a    = go f n_val_args
+       | hasNoRedexes a = go f (n_val_args + 1)
+          -- NB. args 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}
 
-\begin{code}
-dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type))
-dup_tyvar tyvar
-  = getUnique                  `thenUs` \ uniq ->
-    let  new_tyvar = cloneTyVar tyvar uniq  in
-    returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
-
--- same thing all over again --------------------
-
-dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr))
-dup_binder tenv b
-  = if (toplevelishId b) then
-       -- binder is "top-level-ish"; -- it should *NOT* be renamed
-       -- ToDo: it's unsavoury that we return something to heave in env
-       returnUs (b, (b, Var b))
-
-    else -- otherwise, the full business
-       getUnique                           `thenUs`  \ uniq ->
-       let
-           new_b1 = mkIdWithNewUniq b uniq
-           new_b2 = applyTypeEnvToId tenv new_b1
-       in
-       returnUs (new_b2, (b, Var new_b2))
-\end{code}
+