X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=00d572392096bf8d56f0252a1dfd5fc77e1e4114;hb=4fb9c8aa14742cf98c1c0f2be1f98841fad145b8;hp=90bcf9e280cff4fc1b57222cca766dff62e2d2fa;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 90bcf9e..00d5723 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -5,98 +5,116 @@ \begin{code} module CoreUtils ( - IdSubst, SubstCoreExpr(..), - - coreExprType, coreAltsType, exprFreeVars, exprSomeFreeVars, - - exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap, - FormSummary(..), mkFormSummary, whnfOrBottom, - cheapEqExpr, - - substExpr, substId, substIds, - idSpecVars, idFreeVars, - - squashableDictishCcExpr + -- Construction + mkNote, mkInlineMe, mkSCC, mkCoerce, + bindNonRec, mkIfThenElse, mkAltExpr, + mkPiType, + + -- 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 {-# SOURCE #-} CoreUnfold ( noUnfolding, hasUnfolding ) + +import GlaExts -- For `xori` import CoreSyn -import PprCore () -- Instances only -import Var ( IdOrTyVar, isId, isTyVar ) +import CoreFVs ( exprFreeVars ) +import PprCore ( pprCoreExpr ) +import Var ( Var, isId, isTyVar ) import VarSet import VarEnv -import Name ( isLocallyDefined ) -import Const ( Con(..), isWHNFCon, conIsTrivial, conIsCheap ) -import Id ( Id, idType, setIdType, idUnique, idAppIsBottom, - getIdArity, idFreeTyVars, - getIdSpecialisation, setIdSpecialisation, - getInlinePragma, setInlinePragma, - getIdUnfolding, setIdUnfolding +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(..) ) -import SpecEnv ( emptySpecEnv, specEnvToList, isEmptySpecEnv ) -import CostCentre ( isDictCC, CostCentre ) -import Const ( Con, conType ) -import Type ( Type, TyVarSubst, mkFunTy, mkForAllTy, - splitFunTy_maybe, applyTys, tyVarsOfType, tyVarsOfTypes, - fullSubstTy, substTyVar ) -import Unique ( buildIdKey, augmentIdKey ) -import Util ( zipWithEqual, mapAccumL ) +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 TysWiredIn ( boolTy, trueDataCon, falseDataCon ) +import CostCentre ( CostCentre ) +import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply ) +import Maybes ( maybeToBool ) import Outputable -import TysPrim ( alphaTy ) -- Debgging only +import TysPrim ( alphaTy ) -- Debugging only \end{code} %************************************************************************ %* * -\subsection{Substitutions} -%* * -%************************************************************************ - -\begin{code} -type IdSubst = IdEnv SubstCoreExpr -- Maps Ids to SubstCoreExpr - -data SubstCoreExpr - = Done CoreExpr -- No more substitution needed - | SubstMe CoreExpr TyVarSubst IdSubst -- A suspended substitution -\end{code} - -%************************************************************************ -%* * \subsection{Find the type of a Core atom/expression} %* * %************************************************************************ \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 other_note e) = coreExprType e -coreExprType e@(Con con args) = applyTypeToArgs e (conType con) args - -coreExprType (Lam binder expr) - | isId binder = 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" (ppr 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} --- The "e" argument is just for debugging +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} +-- The first argument is just for debugging +applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type applyTypeToArgs e op_ty [] = op_ty applyTypeToArgs e op_ty (Type ty : args) @@ -110,105 +128,224 @@ applyTypeToArgs e op_ty (Type ty : args) applyTypeToArgs e op_ty (other_arg : args) = case (splitFunTy_maybe op_ty) of Just (_, res_ty) -> applyTypeToArgs e res_ty args - Nothing -> pprPanic "applyTypeToArgs" (ppr e) + Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e) \end{code} + %************************************************************************ %* * -\subsection{Figuring out things about expressions} +\subsection{Attaching notes} %* * %************************************************************************ +mkNote removes redundant coercions, and SCCs where possible + \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 - | 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 +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} -mkFormSummary :: CoreExpr -> FormSummary -mkFormSummary expr - = go (0::Int) expr -- The "n" is the number of *value* arguments so far - where - go n (Con con _) | isWHNFCon con = ValueForm - | otherwise = OtherForm +mkInlineMe (Var v) = Var v +mkInlineMe e = Note InlineMe e +\end{code} + - go n (Note _ e) = go n e - go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g) - -- should be treated as a value - go n (Let _ e) = OtherForm - go n (Case _ _ _) = OtherForm +\begin{code} +mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr - 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 +mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr) + = ASSERT( from_ty == to_ty2 ) + mkCoerce to_ty from_ty2 expr - go n (App fun (Type _)) = go n fun -- Ignore type args - go n (App fun arg) = go (n+1) fun +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} - go n (Var f) | idAppIsBottom f n = BottomForm - go 0 (Var f) = VarForm - go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm - | otherwise = OtherForm +\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} -@exprIsTrivial@ is true of expressions we are unconditionally - happy to duplicate; simple variables and constants, - and type applications. -@exprIsDupable@ is true of expressions that can be duplicated at a modest - cost in space, but without duplicating any work. +%************************************************************************ +%* * +\subsection{Other expression construction} +%* * +%************************************************************************ +\begin{code} +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} +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 [] = 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} + + +%************************************************************************ +%* * +\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 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) = conIsCheap con && - all exprIsDupable args && - valArgCount args <= dupAppSize - -exprIsDupable (Note _ e) = exprIsDupable e -exprIsDupable expr = case collectArgs expr of - (Var v, args) -> n_val_args == 0 || - (n_val_args < fun_arity && - all exprIsDupable args && - n_val_args <= dupAppSize) - where - n_val_args = valArgCount args - fun_arity = arityLowerBound (getIdArity v) - - _ -> 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 @@ -218,55 +355,137 @@ 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) + + * error "foo" + (because we are happy to substitute it inside a lambda) - where op is a cheap primitive operator +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} 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 - - (Var f, args) | idAppIsBottom f (length args) - -> True -- Application of a function which - -- always gives bottom; we treat this as - -- a WHNF, because it certainly doesn't - -- need to be shared! - - (Var f, args) -> - let - num_val_args = valArgCount args - in - num_val_args == 0 || -- Just a type application of - -- a variable (f t1 t2 t3) - -- counts as WHNF - num_val_args < arityLowerBound (getIdArity f) - - _ -> False +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 + | 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 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 +==> + 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. + +\begin{code} +exprOkForSpeculation :: CoreExpr -> Bool +exprOkForSpeculation (Lit _) = True +exprOkForSpeculation (Var v) = isUnLiftedType (idType v) +exprOkForSpeculation (Note _ e) = exprOkForSpeculation e +exprOkForSpeculation other_expr + = go other_expr 0 True + where + go (Var f) n_args args_ok + = case globalIdDetails f of + DataConId _ -> True -- The strictness of the constructor has already + -- been expressed by its "wrapper", so we don't need + -- to take the arguments into account + + PrimOpId op -> primOpOkForSpeculation op && args_ok + -- 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} @@ -280,381 +499,439 @@ 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. -We treat applications of buildId and augmentId as honorary WHNFs, because we -want them to get exposed +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 + +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} -I don't like this function but I'n not confidnt enough to change it. - \begin{code} -squashableDictishCcExpr :: CostCentre -> Expr b -> Bool -squashableDictishCcExpr cc expr - | isDictCC cc = False -- that was easy... - | otherwise = squashable expr +exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) +exprIsConApp_maybe expr + = analyse (collectArgs expr) where - squashable (Var _) = True - squashable (Con _ _) = True -- I think so... WDP 94/09 - squashable (App f a) - | isTypeArg a = squashable f - squashable other = False + 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} - -@cheapEqExpr@ is a cheap equality test which bales out fast! - True => definitely equal - False => may or may not be equal +The arity of an expression (in the code-generator sense, i.e. the +number of lambdas at the beginning). \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 (App f1 a1) (App f2 a2) - = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 - -cheapEqExpr (Type t1) (Type t2) = t1 == t2 - -cheapEqExpr _ _ = False +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} %************************************************************************ %* * -\section{Finding the free variables of an expression} +\subsection{Eta reduction and expansion} %* * %************************************************************************ -This function simply finds the free variables of an expression. -So far as type variables are concerned, it only finds tyvars that are +@etaReduce@ trys an eta reduction at the top level of a Core Expr. - * free in type arguments, - * free in the type of a binder, +e.g. \ x y -> f x y ===> f -but not those that are free in the type of variable occurrence. +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} -exprFreeVars :: CoreExpr -> IdOrTyVarSet -- Find all locally-defined free Ids or tyvars -exprFreeVars = exprSomeFreeVars isLocallyDefined - -exprSomeFreeVars :: InterestingVarFun -- Says which Vars are interesting - -> CoreExpr - -> IdOrTyVarSet -exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet - -type InterestingVarFun = IdOrTyVar -> Bool -- True <=> interesting -\end{code} - - -\begin{code} -type FV = InterestingVarFun - -> IdOrTyVarSet -- In scope - -> IdOrTyVarSet -- Free vars - -union :: FV -> FV -> FV -union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope - -noVars :: FV -noVars fv_cand in_scope = emptyVarSet - -oneVar :: IdOrTyVar -> FV -oneVar var fv_cand in_scope - | keep_it fv_cand in_scope var = unitVarSet var - | otherwise = emptyVarSet +etaReduce :: CoreExpr -> CoreExpr + -- ToDo: we should really check that we don't turn a non-bottom + -- lambda into a bottom variable. Sigh -someVars :: IdOrTyVarSet -> FV -someVars vars fv_cand in_scope - = filterVarSet (keep_it fv_cand in_scope) vars +etaReduce expr@(Lam bndr body) + = check (reverse binders) body + where + (binders, body) = collectBinders expr -keep_it fv_cand in_scope var - | var `elemVarSet` in_scope = False - | fv_cand var = True - | otherwise = False + 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 -addBndr :: CoreBndr -> FV -> FV -addBndr bndr fv fv_cand in_scope - | isId bndr = inside_fvs `unionVarSet` someVars (idFreeVars bndr) fv_cand in_scope - | otherwise = inside_fvs - where - inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr) + check _ _ = expr -- Bale out -addBndrs :: [CoreBndr] -> FV -> FV -addBndrs bndrs fv = foldr addBndr fv bndrs +etaReduce expr = expr -- The common case \end{code} - + \begin{code} -expr_fvs :: CoreExpr -> FV - -expr_fvs (Type ty) = someVars (tyVarsOfType ty) -expr_fvs (Var var) = oneVar var -expr_fvs (Con con args) = foldr (union . expr_fvs) noVars args -expr_fvs (Note _ expr) = expr_fvs expr -expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg -expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body) - -expr_fvs (Case scrut bndr alts) - = expr_fvs scrut `union` addBndr bndr (foldr (union. alt_fvs) noVars alts) +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 - alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) + 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 -expr_fvs (Let (NonRec bndr rhs) body) - = expr_fvs rhs `union` addBndr bndr (expr_fvs body) - -expr_fvs (Let (Rec pairs) body) - = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss) - where - (bndrs,rhss) = unzip pairs \end{code} -Given an Id, idSpecVars returns all its specialisations. -We extract these from its SpecEnv. -This is used by the occurrence analyser and free-var finder; -we regard an Id's specialisations as free in the Id's definition. - \begin{code} -idSpecVars :: Id -> IdOrTyVarSet -idSpecVars id - = foldr (unionVarSet . spec_item_fvs) - emptyVarSet - (specEnvToList (getIdSpecialisation id)) - where - spec_item_fvs (tyvars, tys, rhs) = foldl delVarSet - (tyVarsOfTypes tys `unionVarSet` exprFreeVars rhs) - tyvars - -idFreeVars :: Id -> IdOrTyVarSet -idFreeVars id = idSpecVars id `unionVarSet` idFreeTyVars id +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} %************************************************************************ %* * -\section{Substitution} +\subsection{Equality} %* * %************************************************************************ -This expression substituter deals correctly with name capture, much -like Type.substTy. - -BUT NOTE that substExpr silently discards the - unfolding, and - spec env -IdInfo attached to any binders in the expression. It's quite -tricky to do them 'right' in the case of mutually recursive bindings, -and so far has proved unnecessary. +@cheapEqExpr@ is a cheap equality test which bales out fast! + True => definitely equal + False => may or may not be equal \begin{code} -substExpr :: TyVarSubst -> IdSubst -- Substitution - -> IdOrTyVarSet -- Superset of in-scope - -> CoreExpr - -> CoreExpr +cheapEqExpr :: Expr b -> Expr b -> Bool -substExpr te ve in_scope expr = subst_expr (te, ve, in_scope) expr +cheapEqExpr (Var v1) (Var v2) = v1==v2 +cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2 +cheapEqExpr (Type t1) (Type t2) = t1 == t2 -subst_expr env@(te, ve, in_scope) expr - = go expr - where - go (Var v) = case lookupVarEnv ve v of - Just (Done e') - -> e' - - Just (SubstMe e' te' ve') - -> subst_expr (te', ve', in_scope) e' - - Nothing -> case lookupVarSet in_scope v of - Just v' -> Var v' - Nothing -> Var v - -- NB: we look up in the in_scope set because the variable - -- there may have more info. In particular, when substExpr - -- is called from the simplifier, the type inside the *occurrences* - -- of a variable may not be right; we should replace it with the - -- binder, from the in_scope set. - - go (Type ty) = Type (go_ty ty) - go (Con con args) = Con con (map go args) - go (App fun arg) = App (go fun) (go arg) - go (Note note e) = Note (go_note note) (go e) - - go (Lam bndr body) = Lam bndr' (subst_expr env' body) - where - (env', bndr') = go_bndr env bndr - - go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (subst_expr env' body) - where - (env', bndr') = go_bndr env bndr - - go (Let (Rec pairs) body) = Let (Rec pairs') (subst_expr env' body) - where - (ve', in_scope', _, bndrs') - = substIds clone_fn te ve in_scope undefined (map fst pairs) - env' = (te, ve', in_scope') - pairs' = bndrs' `zip` rhss' - rhss' = map (subst_expr env' . snd) pairs - - go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt env') alts) - where - (env', bndr') = go_bndr env bndr - - go_alt env (con, bndrs, rhs) = (con, bndrs', subst_expr env' rhs) - where - (env', bndrs') = mapAccumL go_bndr env bndrs - - go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2) - go_note note = note - - go_ty ty = fullSubstTy te in_scope ty - - go_bndr (te, ve, in_scope) bndr - | isTyVar bndr - = case substTyVar te in_scope bndr of - (te', in_scope', bndr') -> ((te', ve, in_scope'), bndr') - - | otherwise - = case substId clone_fn te ve in_scope undefined bndr of - (ve', in_scope', _, bndr') -> ((te, ve', in_scope'), bndr') - - - clone_fn in_scope _ bndr - | bndr `elemVarSet` in_scope = Just (uniqAway in_scope bndr, undefined) - | otherwise = Nothing - +cheapEqExpr (App f1 a1) (App f2 a2) + = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 + +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} -Substituting in binders is a rather tricky part of the whole compiler. \begin{code} -substIds :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner - -> TyVarSubst -> IdSubst -> IdOrTyVarSet -- Usual stuff - -> us -- Unique supply - -> [Id] - -> (IdSubst, IdOrTyVarSet, -- New id_subst, in_scope - us, -- New unique supply - [Id]) - -substIds clone_fn ty_subst id_subst in_scope us [] - = (id_subst, in_scope, us, []) - -substIds clone_fn ty_subst id_subst in_scope us (id:ids) - = case (substId clone_fn ty_subst id_subst in_scope us id) of { - (id_subst', in_scope', us', id') -> - - case (substIds clone_fn ty_subst id_subst' in_scope' us' ids) of { - (id_subst'', in_scope'', us'', ids') -> - - (id_subst'', in_scope'', us'', id':ids') - }} - - -substId :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner - -> TyVarSubst -> IdSubst -> IdOrTyVarSet -- Usual stuff - -> us -- Unique supply - -> Id - -> (IdSubst, IdOrTyVarSet, -- New id_subst, in_scope - us, -- New unique supply - Id) - --- Returns an Id with empty unfolding and spec-env. --- It's up to the caller to sort these out. - -substId clone_fn - ty_subst id_subst in_scope - us id - | old_id_will_do - -- No need to clone, but we *must* zap any current substitution - -- for the variable. For example: - -- (\x.e) with id_subst = [x |-> e'] - -- Here we must simply zap the substitution for x - = (delVarEnv id_subst id, extendVarSet in_scope id, us, id) - - | otherwise - = (extendVarEnv id_subst id (Done (Var new_id)), - extendVarSet in_scope new_id, - new_us, - new_id) +eqExpr :: CoreExpr -> CoreExpr -> Bool + -- Works ok at more general type, but only needed at CoreExpr +eqExpr e1 e2 + = eq emptyVarEnv e1 e2 where - id_ty = idType id - old_id_will_do = old1 && old2 && old3 && {-old4 && -}not cloned - - -- id1 has its type zapped - (id1,old1) | isEmptyVarEnv ty_subst - || isEmptyVarSet (tyVarsOfType id_ty) = (id, True) - | otherwise = (setIdType id ty', False) - - ty' = fullSubstTy ty_subst in_scope id_ty - - -- id2 has its SpecEnv zapped - -- It's filled in later by - (id2,old2) | isEmptySpecEnv spec_env = (id1, True) - | otherwise = (setIdSpecialisation id1 emptySpecEnv, False) - spec_env = getIdSpecialisation id - - -- id3 has its Unfolding zapped - -- This is very important; occasionally a let-bound binder is used - -- as a binder in some lambda, in which case its unfolding is utterly - -- bogus. Also the unfolding uses old binders so if we left it we'd - -- have to substitute it. Much better simply to give the Id a new - -- unfolding each time, which is what the simplifier does. - (id3,old3) | hasUnfolding (getIdUnfolding id) = (id2 `setIdUnfolding` noUnfolding, False) - | otherwise = (id2, True) - - -- new_id is cloned if necessary - (new_us, new_id, cloned) = case clone_fn in_scope us id3 of - Nothing -> (us, id3, False) - Just (us', id') -> (us', id', True) - - -- new_id_bndr has its Inline info neutered. We must forget about whether it - -- was marked safe-to-inline, because that isn't necessarily true in - -- the simplified expression. We do this for the *binder* which will - -- be used at the binding site, but we *dont* do it for new_id, which - -- is put into the in_scope env. Why not? Because the in_scope env - -- carries down the occurrence information to usage sites! - -- - -- Net result: post-simplification, occurrences may have over-optimistic - -- occurrence info, but binders won't. -{- (new_id_bndr, old4) - = case getInlinePragma id of - ICanSafelyBeINLINEd _ _ -> (setInlinePragma new_id NoInlinePragInfo, False) - other -> (new_id, True) --} + -- 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) = length ps1 == length ps2 && + and (zipWith eq_rhs ps1 ps2) && + eq env' e1 e2 + where + env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2] + eq_rhs (_,r1) (_,r2) = eq env' r1 r2 + eq env (Case e1 v1 a1) + (Case e2 v2 a2) = eq env e1 e2 && + length a1 == length a2 && + and (zipWith (eq_alt env') a1 a2) + where + env' = extendVarEnv env v1 v2 + + eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2 + eq env (Type t1) (Type t2) = t1 == t2 + eq env 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==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}