[project @ 2001-03-19 16:20:44 by simonpj]
[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreUtils.lhs
index 049578e..00d5723 100644 (file)
@@ -5,41 +5,68 @@
 
 \begin{code}
 module CoreUtils (
-       coreExprType, coreAltsType,
+       -- Construction
+       mkNote, mkInlineMe, mkSCC, mkCoerce,
+       bindNonRec, mkIfThenElse, mkAltExpr,
+        mkPiType,
 
-       exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap,
-       exprOkForSpeculation,
-       FormSummary(..), mkFormSummary, whnfOrBottom, exprArity,
+       -- Taking expressions apart
+       findDefault, findAlt,
+
+       -- Properties of expressions
+       exprType, coreAltsType, 
+       exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, 
+       exprIsValue,exprOkForSpeculation, exprIsBig, 
+       exprIsConApp_maybe, exprIsAtom,
+       idAppIsBottom, idAppIsCheap,
+       exprArity,
+
+       -- Expr transformation
+       etaReduce, etaExpand,
+       exprArity, exprEtaExpandArity, 
+
+       -- Size
+       coreBindsSize,
+
+       -- Hashing
+       hashExpr,
+
+       -- Equality
        cheapEqExpr, eqExpr, applyTypeToArgs
     ) where
 
 #include "HsVersions.h"
 
 
+import GlaExts         -- For `xori` 
+
 import CoreSyn
+import CoreFVs         ( exprFreeVars )
 import PprCore         ( pprCoreExpr )
-import Var             ( IdOrTyVar, isId, isTyVar )
+import Var             ( Var, isId, isTyVar )
 import VarSet
 import VarEnv
-import Name            ( isLocallyDefined )
-import Const           ( Con, isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
-                         conType, conOkForSpeculation, conStrictness
-                       )
-import Id              ( Id, idType, setIdType, idUnique, idAppIsBottom,
-                         getIdArity,
-                         getIdSpecialisation, setIdSpecialisation,
-                         getInlinePragma, setInlinePragma,
-                         getIdUnfolding, setIdUnfolding, idInfo
+import Name            ( hashName )
+import Literal         ( hashLiteral, literalType, litIsDupable )
+import DataCon         ( DataCon, dataConRepArity )
+import PrimOp          ( primOpOkForSpeculation, primOpIsCheap, 
+                         primOpIsDupable )
+import Id              ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo, 
+                         mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
+                         isDataConId_maybe, isPrimOpId_maybe, mkSysLocal, hasNoBinding
                        )
-import IdInfo          ( arityLowerBound, InlinePragInfo(..), lbvarInfo, LBVarInfo(..) )
-import Type            ( Type, mkFunTy, mkForAllTy,
-                         splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
-                          isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
-                         tidyTyVar, applyTys, isUnLiftedType
+import IdInfo          ( LBVarInfo(..),  
+                         GlobalIdDetails(..),
+                         megaSeqIdInfo )
+import Demand          ( appIsBottom )
+import Type            ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, 
+                         applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
+                         splitForAllTy_maybe, splitNewType_maybe
                        )
-import Demand          ( isPrim, isLazy )
-import Unique          ( buildIdKey, augmentIdKey )
-import Util            ( zipWithEqual, mapAccumL )
+import TysWiredIn      ( boolTy, trueDataCon, falseDataCon )
+import CostCentre      ( CostCentre )
+import UniqSupply      ( UniqSupply, splitUniqSupply, uniqFromSupply )
+import Maybes          ( maybeToBool )
 import Outputable
 import TysPrim         ( alphaTy )     -- Debugging only
 \end{code}
@@ -52,31 +79,37 @@ import TysPrim              ( alphaTy )     -- Debugging only
 %************************************************************************
 
 \begin{code}
-coreExprType :: CoreExpr -> Type
-
-coreExprType (Var var)             = idType var
-coreExprType (Let _ body)          = coreExprType body
-coreExprType (Case _ _ alts)        = coreAltsType alts
-coreExprType (Note (Coerce ty _) e) = ty
-coreExprType (Note (TermUsg u) e)   = mkUsgTy u (unUsgTy (coreExprType e))
-coreExprType (Note other_note e)    = coreExprType e
-coreExprType e@(Con con args)       = applyTypeToArgs e (conType con) args
-
-coreExprType (Lam binder expr)
-  | isId binder    = (case (lbvarInfo . idInfo) binder of
-                       IsOneShotLambda -> mkUsgTy UsOnce
-                       otherwise       -> id) $
-                     idType binder `mkFunTy` coreExprType expr
-  | isTyVar binder = mkForAllTy binder (coreExprType expr)
-
-coreExprType e@(App _ _)
+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 (coreExprType fun) args
+       (fun, args) -> applyTypeToArgs e (exprType fun) args
 
-coreExprType other = pprTrace "coreExprType" (pprCoreExpr other) alphaTy
+exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
 
 coreAltsType :: [CoreAlt] -> Type
-coreAltsType ((_,_,rhs) : _) = coreExprType rhs
+coreAltsType ((_,_,rhs) : _) = exprType rhs
+\end{code}
+
+@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.
+
+\begin{code}
+mkPiType :: Var -> Type -> Type                -- The more polymorphic version doesn't work...
+mkPiType v ty | isId v    = (case idLBVarInfo v of
+                               LBVarInfo u -> mkUTy u
+                               otherwise   -> id) $
+                            mkFunTy (idType v) ty
+             | isTyVar v = mkForAllTy v ty
 \end{code}
 
 \begin{code}
@@ -86,7 +119,6 @@ applyTypeToArgs e op_ty [] = op_ty
 
 applyTypeToArgs e op_ty (Type ty : args)
   =    -- Accumulate type arguments so we can instantiate all at once
-    ASSERT2( all isNotUsgTy tys, ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+> ppr (Type ty : args) <+> text "i.e." <+> ppr tys )
     applyTypeToArgs e (applyTys op_ty tys) rest_args
   where
     (tys, rest_args)        = go [ty] args
@@ -100,107 +132,220 @@ applyTypeToArgs e op_ty (other_arg : args)
 \end{code}
 
 
+
 %************************************************************************
 %*                                                                     *
-\subsection{Figuring out things about expressions}
+\subsection{Attaching notes}
+%*                                                                     *
+%************************************************************************
+
+mkNote removes redundant coercions, and SCCs where possible
+
+\begin{code}
+mkNote :: Note -> CoreExpr -> CoreExpr
+mkNote (Coerce to_ty from_ty) expr = mkCoerce 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}
+mkInlineMe (Var v) = Var v
+mkInlineMe e      = Note InlineMe e
+\end{code}
+
+
+
+\begin{code}
+mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
+
+mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
+  = ASSERT( from_ty == to_ty2 )
+    mkCoerce to_ty from_ty2 expr
+
+mkCoerce to_ty from_ty expr
+  | to_ty == from_ty = expr
+  | otherwise       = ASSERT( from_ty == exprType expr )
+                      Note (Coerce to_ty from_ty) expr
+\end{code}
+
+\begin{code}
+mkSCC :: CostCentre -> Expr b -> Expr b
+       -- Note: Nested SCC's *are* preserved for the benefit of
+       --       cost centre stack profiling (Durham)
+
+mkSCC cc (Lit lit) = Lit lit
+mkSCC cc (Lam x e) = Lam x (mkSCC cc e)        -- Move _scc_ inside lambda
+mkSCC cc expr     = Note (SCC cc) expr
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Other expression construction}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
-data FormSummary
-  = VarForm            -- Expression is a variable (or scc var, etc)
-
-  | ValueForm          -- Expression is a value: i.e. a value-lambda,constructor, or literal
-                       --      May 1999: I'm experimenting with allowing "cheap" non-values
-                       --      here.
-
-  | BottomForm         -- Expression is guaranteed to be bottom. We're more gung
-                       -- ho about inlining such things, because it can't waste work
-  | OtherForm          -- Anything else
-
-instance Outputable FormSummary where
-   ppr VarForm    = ptext SLIT("Var")
-   ppr ValueForm  = ptext SLIT("Value")
-   ppr BottomForm = ptext SLIT("Bot")
-   ppr OtherForm  = ptext SLIT("Other")
-
-whnfOrBottom :: FormSummary -> Bool
-whnfOrBottom VarForm    = True
-whnfOrBottom ValueForm  = True
-whnfOrBottom BottomForm = True
-whnfOrBottom OtherForm  = False
+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 
+  | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
+  | otherwise                   = Let (NonRec bndr rhs) body
 \end{code}
 
 \begin{code}
-mkFormSummary :: CoreExpr -> FormSummary
-mkFormSummary expr
-  = go (0::Int) expr   -- The "n" is the number of *value* arguments so far
+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}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Taking expressions apart}
+%*                                                                     *
+%************************************************************************
+
+
+\begin{code}
+findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
+findDefault []                         = ([], Nothing)
+findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args ) 
+                                         ([], Just rhs)
+findDefault (alt : alts)               = case findDefault alts of 
+                                           (alts', deflt) -> (alt : alts', deflt)
+
+findAlt :: AltCon -> [CoreAlt] -> CoreAlt
+findAlt con alts
+  = go alts
   where
-    go n (Con con _) | isWHNFCon con = ValueForm
-                    | otherwise     = OtherForm
-
-    go n (Note _ e)         = go n e
-
-    go n (Let (NonRec b r) e) | exprIsCheap r = go n e -- let f = f' alpha in (f,g) 
-                                                       -- should be treated as a value
-    go n (Let _ e)    = OtherForm
-
-       -- We want selectors to look like values
-       -- e.g.  case x of { (a,b) -> a }
-       -- should give a ValueForm, so that it will be inlined
-       -- vigorously
-    go n expr@(Case _ _ _) | exprIsCheap expr = ValueForm
-                          | otherwise        = OtherForm
-
-    go 0 (Lam x e) | isId x    = ValueForm     -- NB: \x.bottom /= bottom!
-                  | otherwise = go 0 e
-    go n (Lam x e) | isId x    = go (n-1) e    -- Applied lambda
-                  | otherwise = go n e
-
-    go n (App fun (Type _)) = go n fun         -- Ignore type args
-    go n (App fun arg)      = go (n+1) fun
-
-    go n (Var f) | idAppIsBottom f n = BottomForm
-    go 0 (Var f)                    = VarForm
-    go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm
-                | otherwise                          = OtherForm
+    go []          = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
+    go (alt : alts) | matches alt = alt
+                   | otherwise   = go alts
+
+    matches (DEFAULT, _, _) = True
+    matches (con1, _, _)    = con == con1
 \end{code}
 
-@exprIsTrivial@        is true of expressions we are unconditionally 
-               happy to duplicate; simple variables and constants,
-               and type applications.
+
+%************************************************************************
+%*                                                                     *
+\subsection{Figuring out things about expressions}
+%*                                                                     *
+%************************************************************************
+
+@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 
 
 @exprIsBottom@ is true of expressions that are guaranteed to diverge
 
 
 \begin{code}
-exprIsTrivial (Type _)      = True
-exprIsTrivial (Var v)       = True
-exprIsTrivial (App e arg)    = isTypeArg arg && exprIsTrivial e
-exprIsTrivial (Note _ e)     = exprIsTrivial e
-exprIsTrivial (Con con args) = conIsTrivial con && all isTypeArg args
-exprIsTrivial (Lam b body)   | isTyVar b = exprIsTrivial body
-exprIsTrivial other         = False
+exprIsTrivial (Var v)
+  | hasNoBinding v                    = idArity v == 0
+       -- WAS: | Just op <- isPrimOpId_maybe v      = primOpIsDupable op
+       -- The idea here is that a constructor worker, like $wJust, is
+       -- really short for (\x -> $wJust x), becuase $wJust has no binding.
+       -- So it should be treated like a lambda.
+       -- Ditto unsaturated primops.
+       -- This came up when dealing with eta expansion/reduction for
+       --      x = $wJust
+       -- Here we want to eta-expand.  This looks like an optimisation,
+       -- but it's important (albeit tiresome) that CoreSat doesn't increase 
+       -- anything's arity
+  | otherwise                          = True
+exprIsTrivial (Type _)                = True
+exprIsTrivial (Lit lit)               = True
+exprIsTrivial (App e arg)             = isTypeArg arg && exprIsTrivial e
+exprIsTrivial (Note _ e)              = exprIsTrivial e
+exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
+exprIsTrivial other                   = False
+
+exprIsAtom :: CoreExpr -> Bool
+-- Used to decide whether to let-binding an STG argument
+-- when compiling to ILX => type applications are not allowed
+exprIsAtom (Var v)    = True   -- primOpIsDupable?
+exprIsAtom (Lit lit)  = True
+exprIsAtom (Type ty)  = True
+exprIsAtom (Note (SCC _) e) = False
+exprIsAtom (Note _ e) = exprIsAtom e
+exprIsAtom other      = False
 \end{code}
 
 
 @exprIsDupable@        is true of expressions that can be duplicated at a modest
-               cost in space.  This will only happen in different case
+               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}
-exprIsDupable (Type _)      = True
-exprIsDupable (Con con args) = conIsDupable con && 
-                              all exprIsDupable args &&
-                              valArgCount args <= dupAppSize
-
-exprIsDupable (Note _ e)     = exprIsDupable e
-exprIsDupable expr          = case collectArgs expr of  
-                                 (Var f, args) ->  valArgCount args <= dupAppSize
-                                 other         ->  False
+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
+    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
@@ -210,64 +355,101 @@ dupAppSize = 4           -- Size of application we are prepared to duplicate
 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.]
-By ``cheap'' we mean a computation we're willing to push inside a lambda 
-in order to bring a couple of lambdas together.  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:
+
+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:
 
   *    case e of
          pi -> ei
+       (where e, and all the ei are cheap)
 
-       where e, and all the ei are cheap; and
-
-  *    let x = e
-       in b
-
-       where e and b are cheap; and
+  *    let x = e in b
+       (where e and b are cheap)
 
   *    op x1 ... xn
+       (where op is a cheap primitive operator)
 
-       where op is a cheap primitive operator
+  *    error "foo"
+       (because we are happy to substitute it inside a lambda)
 
-\begin{code}
-exprIsCheap :: CoreExpr -> Bool
-exprIsCheap (Type _)           = True
-exprIsCheap (Var _)            = True
-exprIsCheap (Con con args)     = conIsCheap con && all exprIsCheap args
-exprIsCheap (Note _ e)         = exprIsCheap e
-exprIsCheap (Lam x e)          = if isId x then True else exprIsCheap e
-exprIsCheap (Let bind body)    = all exprIsCheap (rhssOfBind bind) && exprIsCheap body
-exprIsCheap (Case scrut _ alts) = exprIsCheap scrut && 
-                                 all (\(_,_,rhs) -> exprIsCheap rhs) alts
-
-exprIsCheap other_expr   -- look for manifest partial application
-  = case collectArgs other_expr of
-       (f, args) -> isPap f (valArgCount args) && all exprIsCheap args
-\end{code}
+Notice that a variable is considered 'cheap': we can push it inside a lambda,
+because sharing will make sure it is only evaluated once.
 
 \begin{code}
-isPap :: CoreExpr              -- Function
-      -> Int                   -- Number of value args
-      -> Bool
-isPap (Var f) n_val_args 
-  =    idAppIsBottom f n_val_args 
-                               -- Application of a function which
-                               -- always gives bottom; we treat this as
-                               -- a WHNF, because it certainly doesn't
-                               -- need to be shared!
-
-    || n_val_args == 0                 -- Just a type application of
+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)            = if isId x then True else 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
+    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 
+       | isTypeArg 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
-
-    || n_val_args < arityLowerBound (getIdArity f)
-               
-isPap fun n_val_args = False
+  | otherwise = case globalIdDetails id of
+                 DataConId _   -> True                 
+                 RecordSelId _ -> True                 -- I'm experimenting with making record selection
+                                                       -- look cheap, so we will substitute it inside a
+                                                       -- lambda.  Particularly for dictionary field selection
+
+                 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}
 
-exprOkForSpeculation returns True of an UNLIFTED-TYPE expression that it is safe
-to evaluate even if normal order eval might not evaluate the expression 
-at all.  E.G.
+exprOkForSpeculation returns True of an expression that it is
+
+       * safe to evaluate even if normal order eval might not 
+         evaluate the expression at all, or
+
+       * safe *not* to evaluate even if normal order would do so
+
+It returns True iff
+
+       the expression guarantees to terminate, 
+       soon, 
+       without raising an exception,
+       without causing a side effect (e.g. writing a mutable variable)
+
+E.G.
        let x = case y# +# 1# of { r# -> I# r# }
        in E
 ==>
@@ -281,26 +463,29 @@ side effects, and can't diverge or raise an exception.
 
 \begin{code}
 exprOkForSpeculation :: CoreExpr -> Bool
-exprOkForSpeculation (Var v)        = True     -- Unlifted type => already evaluated
-
-exprOkForSpeculation (Note _ e)          = exprOkForSpeculation e
-exprOkForSpeculation (Let (NonRec b r) e) = isUnLiftedType (idType b) && 
-                                           exprOkForSpeculation r && 
-                                           exprOkForSpeculation e
-exprOkForSpeculation (Let (Rec _) _) = False
-exprOkForSpeculation (Case _ _ _)    = False   -- Conservative
-exprOkForSpeculation (App _ _)       = False
-
-exprOkForSpeculation (Con con args)
-  = conOkForSpeculation con &&
-    and (zipWith ok (filter isValArg args) (fst (conStrictness con)))
+exprOkForSpeculation (Lit _)    = True
+exprOkForSpeculation (Var v)    = isUnLiftedType (idType v)
+exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
+exprOkForSpeculation other_expr
+  = go other_expr 0 True
   where
-    ok arg demand | isLazy demand = True
-                 | isPrim demand = exprOkForSpeculation arg
-                 | otherwise     = False
-
-exprOkForSpeculation other = panic "exprOkForSpeculation"
-       -- Lam, Type
+    go (Var f) n_args args_ok 
+      = case globalIdDetails f of
+         DataConId _ -> True   -- The strictness of the constructor has already
+                               -- been expressed by its "wrapper", so we don't need
+                               -- to take the arguments into account
+
+         PrimOpId op -> primOpOkForSpeculation op && args_ok
+                               -- A bit conservative: we don't really need
+                               -- to care about lazy arguments, but this is easy
+
+         other -> False
+       
+    go (App f a) n_args args_ok 
+       | isTypeArg a = go f n_args       args_ok
+       | otherwise   = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
+
+    go other n_args args_ok = False
 \end{code}
 
 
@@ -314,46 +499,280 @@ exprIsBottom e = go 0 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 (Con _ _)    = False
+                go n (Lit _)      = False
                 go n (Lam _ _)    = False
+
+idAppIsBottom :: Id -> Int -> Bool
+idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
 \end{code}
 
-exprIsWHNF reports True for head normal forms.  Note that does not necessarily
-mean *normal* forms; constructors might have non-trivial argument expressions, for
-example.  We use a let binding for WHNFs, rather than a case binding, even if it's
-used strictly.  We try to expose WHNFs by floating lets out of the RHS of lets.
+@exprIsValue@ returns true for expressions that are certainly *already* 
+evaluated to WHNF.  This is used to decide wether it's ok to change
+       case x of _ -> e   ===>   e
+
+and to decide whether it's safe to discard a `seq`
+
+So, it does *not* treat variables as evaluated, unless they say they are.
+
+But it *does* treat partial applications and constructor applications
+as values, even if their arguments are non-trivial; 
+       e.g.  (:) (f x) (map f xs)      is a value
+             map (...redex...)         is a value
+Because `seq` on such things completes immediately
 
-We treat applications of buildId and augmentId as honorary WHNFs, because we
-want them to get exposed
+A possible worry: constructors with unboxed args:
+               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}
-exprIsWHNF :: CoreExpr -> Bool -- True => Variable, value-lambda, constructor, PAP
-exprIsWHNF (Type ty)         = True    -- Types are honorary WHNFs; we don't mind
+exprIsValue :: CoreExpr -> Bool                -- True => Value-lambda, constructor, PAP
+exprIsValue (Type ty)    = True        -- Types are honorary Values; we don't mind
                                        -- copying them
-exprIsWHNF (Var v)           = True
-exprIsWHNF (Lam b e)         = isId b || exprIsWHNF e
-exprIsWHNF (Note _ e)        = exprIsWHNF e
-exprIsWHNF (Let _ e)          = False
-exprIsWHNF (Case _ _ _)       = False
-exprIsWHNF (Con con _)        = isWHNFCon con 
-exprIsWHNF e@(App _ _)        = case collectArgs e of  
-                                 (Var v, args) -> n_val_args == 0 || 
-                                                  fun_arity > n_val_args ||
-                                                  v_uniq == buildIdKey ||
-                                                  v_uniq == augmentIdKey
-                                               where
-                                                  n_val_args = valArgCount args
-                                                  fun_arity  = arityLowerBound (getIdArity v)
-                                                  v_uniq     = idUnique v
-
-                                 _             -> False
+exprIsValue (Lit l)      = True
+exprIsValue (Lam b e)            = isId b || exprIsValue e
+exprIsValue (Note _ e)           = exprIsValue e
+exprIsValue other_expr
+  = go other_expr 0
+  where
+    go (Var f) n_args = idAppIsValue f n_args
+       
+    go (App f a) n_args
+       | isTypeArg a = go f n_args
+       | otherwise   = go f (n_args + 1) 
+
+    go (Note _ f) n_args = go f n_args
+
+    go other n_args = False
+
+idAppIsValue :: Id -> Int -> Bool
+idAppIsValue id n_val_args 
+  = case globalIdDetails id of
+       DataConId _ -> True
+       PrimOpId _  -> n_val_args < idArity id
+       other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
+             | otherwise       -> n_val_args < idArity id
+       -- A worry: what if an Id's unfolding is just itself: 
+       -- then we could get an infinite loop...
+\end{code}
+
+\begin{code}
+exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
+exprIsConApp_maybe expr
+  = analyse (collectArgs expr)
+  where
+    analyse (Var fun, args)
+       | Just con <- isDataConId_maybe fun,
+         length args >= 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}
+
+The arity of an expression (in the code-generator sense, i.e. the
+number of lambdas at the beginning).
+
+\begin{code}
+exprArity :: CoreExpr -> Int
+exprArity (Lam x e)
+  | isTyVar x = exprArity e
+  | otherwise = 1 + exprArity e
+exprArity (Note _ e)
+  -- Ignore coercions.   Top level sccs are removed by the final 
+  -- profiling pass, so we ignore those too.
+  = exprArity e
+exprArity _ = 0
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Eta reduction and expansion}
+%*                                                                     *
+%************************************************************************
+
+@etaReduce@ trys an eta reduction at the top level of a Core Expr.
+
+e.g.   \ x y -> f x y  ===>  f
+
+But we only do this if it gets rid of a whole lambda, not part.
+The idea is that lambdas are often quite helpful: they indicate
+head normal forms, so we don't want to chuck them away lightly.
+
+\begin{code}
+etaReduce :: CoreExpr -> CoreExpr
+               -- ToDo: we should really check that we don't turn a non-bottom
+               -- lambda into a bottom variable.  Sigh
+
+etaReduce expr@(Lam bndr body)
+  = check (reverse binders) body
+  where
+    (binders, body) = collectBinders expr
+
+    check [] body
+       | not (any (`elemVarSet` body_fvs) binders)
+       = body                  -- Success!
+       where
+         body_fvs = exprFreeVars body
+
+    check (b : bs) (App fun arg)
+       |  (varToCoreExpr b `cheapEqExpr` arg)
+       = check bs fun
+
+    check _ _ = expr   -- Bale out
+
+etaReduce expr = expr          -- The common case
 \end{code}
+       
 
 \begin{code}
-exprArity :: CoreExpr -> Int   -- How many value lambdas are at the top
-exprArity (Lam b e) | isTyVar b = exprArity e
-                   | otherwise = 1 + exprArity e
-exprArity other                        = 0
+exprEtaExpandArity :: CoreExpr -> (Int, Bool)  
+-- The Int is number of value args the thing can be 
+--     applied to without doing much work
+-- The Bool is True iff there are enough explicit value lambdas
+--     at the top to make this arity apparent
+--     (but ignore it when arity==0)
+
+-- This is used when eta expanding
+--     e  ==>  \xy -> e x y
+--
+-- 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
+--
+-- Consider    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 extra Bool returned by go1
+--     NB: this is particularly important/useful for IO state 
+--     transformers, where we often get
+--             let x = E in \ s -> ...
+--     and the \s is a real-world state token abstraction.  Such 
+--     abstractions are almost invariably 1-shot, so we want to
+--     pull the \s out, past the let x=E.  
+--     The hack is in Id.isOneShotLambda
+
+exprEtaExpandArity e
+  = go 0 e
+  where
+    go :: Int -> CoreExpr -> (Int,Bool)
+    go ar (Lam x e)  | isId x          = go (ar+1) e
+                    | otherwise        = go ar e
+    go ar (Note n e) | ok_note n       = go ar e
+    go ar other                        = (ar + ar', ar' == 0)
+                                       where
+                                         ar' = length (go1 other)
+
+    go1 :: CoreExpr -> [Bool]
+       -- (go1 e) = [b1,..,bn]
+       -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
+       -- where bi is True <=> the lambda is one-shot
+
+    go1 (Note n e) | ok_note n = go1 e
+    go1 (Var v)                        = replicate (idArity v) False   -- When the type of the Id
+                                                               -- encodes one-shot-ness, use
+                                                               -- th iinfo here
+
+       -- Lambdas; increase arity
+    go1 (Lam x e)  | isId x     = isOneShotLambda x : go1 e
+                  | otherwise  = go1 e
+
+       -- Applications; decrease arity
+    go1 (App f (Type _))       = go1 f
+    go1 (App f a)              = case go1 f of
+                                   (one_shot : xs) | one_shot || exprIsCheap a -> xs
+                                   other                                       -> []
+                                                          
+       -- Case/Let; keep arity if either the expression is cheap
+       -- or it's a 1-shot lambda
+    go1 (Case scrut _ alts) = case foldr1 (zipWith (&&)) [go1 rhs | (_,_,rhs) <- alts] of
+                               xs@(one_shot : _) | one_shot || exprIsCheap scrut -> xs
+                               other                                             -> []
+    go1 (Let b e) = case go1 e of
+                     xs@(one_shot : _) | one_shot || all exprIsCheap (rhssOfBind b) -> xs
+                     other                                                          -> []
+
+    go1 other = []
+    
+    ok_note (Coerce _ _) = True
+    ok_note InlineCall   = True
+    ok_note other        = False
+           -- Notice that we do not look through __inline_me__
+           -- This one is a bit more surprising, but consider
+           --  f = _inline_me (\x -> e)
+           -- We DO NOT want to eta expand this to
+           --  f = \x -> (_inline_me (\x -> e)) x
+           -- because the _inline_me gets dropped now it is applied, 
+           -- giving just
+           --  f = \x -> e
+           -- A Bad Idea
+
+min_zero :: [Int] -> Int       -- Find the minimum, but zero is the smallest
+min_zero (x:xs) = go x xs
+               where
+                 go 0   xs                 = 0         -- Nothing beats zero
+                 go min []                 = min
+                 go min (x:xs) | x < min   = go x xs
+                               | otherwise = go min xs 
+
+\end{code}
+
+
+\begin{code}
+etaExpand :: Int               -- Add this number of value args
+         -> UniqSupply
+         -> 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'
+--
+-- etaExpand deals with for-alls and coerces. For example:
+--             etaExpand 1 E
+-- where  E :: forall a. T
+--       newtype T = MkT (A -> B)
+--
+-- would return
+--     (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
+
+-- (case x of { I# x -> /\ a -> coerce T E)
+
+etaExpand n us expr ty
+  | n == 0     -- Saturated, so nothing to do
+  = expr
+
+  | otherwise  -- An unsaturated constructor or primop; eta expand it
+  = case splitForAllTy_maybe ty of { 
+         Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
+
+       ; Nothing ->
+  
+       case splitFunTy_maybe ty of {
+         Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
+                               where
+                                  arg1       = mkSysLocal SLIT("eta") uniq arg_ty
+                                  (us1, us2) = splitUniqSupply us
+                                  uniq       = uniqFromSupply us1 
+                                  
+       ; Nothing -> 
+  
+       case splitNewType_maybe ty of {
+         Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
+  
+         Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
+       }}}
 \end{code}
 
 
@@ -370,17 +789,22 @@ exprArity other                   = 0
 \begin{code}
 cheapEqExpr :: Expr b -> Expr b -> Bool
 
-cheapEqExpr (Var v1) (Var v2) = v1==v2
-cheapEqExpr (Con con1 args1) (Con con2 args2)
-  = con1 == con2 && 
-    and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2)
+cheapEqExpr (Var v1)   (Var v2)   = v1==v2
+cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
+cheapEqExpr (Type t1)  (Type t2)  = t1 == t2
 
 cheapEqExpr (App f1 a1) (App f2 a2)
   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 
-cheapEqExpr (Type t1) (Type t2) = t1 == t2
-
 cheapEqExpr _ _ = False
+
+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}
 
 
@@ -397,7 +821,7 @@ eqExpr e1 e2
                                  Just v1' -> v1' == v2
                                  Nothing  -> v1  == v2
 
-    eq env (Con c1 es1) (Con c2 es2) = c1 == c2 && eq_list env es1 es2
+    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)
@@ -428,8 +852,86 @@ eqExpr e1 e2
                                         eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
 
     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
-    eq_note env (Coerce f1 t1) (Coerce f2 t2) = f1==f2 && t1==t2
+    eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
     eq_note env InlineCall     InlineCall     = True
     eq_note env other1        other2         = False
 \end{code}
 
+
+%************************************************************************
+%*                                                                     *
+\subsection{The size of an expression}
+%*                                                                     *
+%************************************************************************
+
+\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)       = varSize v 
+exprSize (Lit lit)     = lit `seq` 1
+exprSize (App f a)     = exprSize f + exprSize a
+exprSize (Lam b e)     = varSize b + exprSize e
+exprSize (Let b e)     = bindSize b + exprSize e
+exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
+exprSize (Note n e)    = noteSize n + exprSize e
+exprSize (Type t)      = seqType t `seq` 1
+
+noteSize (SCC cc)       = cc `seq` 1
+noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
+noteSize InlineCall     = 1
+noteSize InlineMe       = 1
+
+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}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Hashing}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+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}