\begin{code}
module CoreUtils (
- IdSubst, SubstCoreExpr(..),
+ -- Construction
+ mkNote, mkInlineMe, mkSCC, mkCoerce,
+ bindNonRec, mkIfThenElse, mkAltExpr,
+ mkPiType,
- coreExprType, coreAltsType, exprFreeVars, exprSomeFreeVars,
+ -- Properties of expressions
+ exprType, coreAltsType, exprArity,
+ exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
+ exprIsValue,exprOkForSpeculation, exprIsBig,
+ exprIsConApp_maybe,
+ idAppIsBottom, idAppIsCheap,
- exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap,
- FormSummary(..), mkFormSummary, whnfOrBottom,
- cheapEqExpr,
+ -- Expr transformation
+ etaReduceExpr, exprEtaExpandArity,
- substExpr, substId, substIds,
- idSpecVars, idFreeVars
+ -- 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 ( isLocallyDefined, hashName )
+import Literal ( Literal, hashLiteral, literalType, litIsDupable )
+import DataCon ( DataCon, dataConRepArity )
+import PrimOp ( primOpOkForSpeculation, primOpIsCheap,
+ primOpIsDupable )
+import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo,
+ mkWildId, idArity, idName, idUnfolding, idInfo,
+ isDataConId_maybe, isPrimOpId_maybe
+ )
+import IdInfo ( arityLowerBound, InlinePragInfo(..),
+ LBVarInfo(..),
+ IdFlavour(..),
+ megaSeqIdInfo )
+import Demand ( appIsBottom )
+import Type ( Type, mkFunTy, mkForAllTy,
+ splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
+ isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
+ applyTys, isUnLiftedType, seqType
)
-import IdInfo ( arityLowerBound, InlinePragInfo(..) )
-import SpecEnv ( emptySpecEnv, specEnvToList, isEmptySpecEnv )
+import TysWiredIn ( boolTy, stringTy, trueDataCon, falseDataCon )
import CostCentre ( 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 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 (TermUsg u) e) = mkUsgTy u (unUsgTy (exprType 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
+ IsOneShotLambda -> mkUsgTy UsOnce
+ 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)
= -- 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
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.
+
\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 e | exprIsTrivial e = e
+ | otherwise = 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
- 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
+\begin{code}
+mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
- 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 (Note (Coerce to_ty2 from_ty2) expr)
+ = ASSERT( from_ty == to_ty2 )
+ mkCoerce to_ty from_ty2 expr
- go n (Var f) | idAppIsBottom f n = BottomForm
- go 0 (Var f) = VarForm
- go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm
- | otherwise = OtherForm
+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}
-@exprIsTrivial@ is true of expressions we are unconditionally
- happy to duplicate; simple variables and constants,
- and type applications.
+\begin{code}
+mkSCC :: CostCentre -> Expr b -> Expr b
+ -- Note: Nested SCC's *are* preserved for the benefit of
+ -- cost centre stack profiling (Durham)
-@exprIsDupable@ is true of expressions that can be duplicated at a modest
- cost in space, but without duplicating any work.
+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}
+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{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)
+ | Just op <- isPrimOpId_maybe v = primOpIsDupable op
+ | 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
\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 (Var v) = True
+exprIsDupable (Lit lit) = litIsDupable lit
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 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
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 op is a cheap primitive operator
+ * error "foo"
+
+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 _ e) = exprIsCheap e
+exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
+exprIsCheap (Case (Var v) _ alts) = and [exprIsCheap rhs | (_,_,rhs) <- alts]
+ -- Experimentally, treat (case x of ...) as cheap
+ -- This improves arities of overloaded functions where
+ -- there is only dictionary selection (no construction) involved
+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
+ -- a WHNF, 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 idFlavour 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 idFlavour 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}
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
-We treat applications of buildId and augmentId as honorary WHNFs, because we
-want them to get exposed
+and to decide whether it's safe to discard a `seq`
+
+So, it does *not* treat variables as evaluated, unless they say they are
\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 idFlavour 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}
-@cheapEqExpr@ is a cheap equality test which bales out fast!
- True => definitely equal
- False => may or may not be equal
-
\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)
+exprArity :: CoreExpr -> Int -- How many value lambdas are at the top
+exprArity (Lam b e) | isTyVar b = exprArity e
+ | otherwise = 1 + exprArity e
+
+exprArity (Note note e) | ok_note note = exprArity e
+ where
+ ok_note (Coerce _ _) = True
+ -- We *do* look through coerces when getting arities.
+ -- Reason: arities are to do with *representation* and
+ -- work duplication.
+ ok_note InlineMe = True
+ ok_note InlineCall = True
+ ok_note other = False
+ -- SCC and TermUsg might be over-conservative?
+
+exprArity other = 0
+\end{code}
-cheapEqExpr (App f1 a1) (App f2 a2)
- = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
+\begin{code}
+exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
+exprIsConApp_maybe expr
+ = analyse (collectArgs expr)
+ where
+ analyse (Var fun, args)
+ | maybeToBool maybe_con_app = maybe_con_app
+ where
+ maybe_con_app = case isDataConId_maybe fun of
+ Just con | length args >= dataConRepArity con
+ -- Might be > because the arity excludes type args
+ -> Just (con, args)
+ other -> Nothing
-cheapEqExpr (Type t1) (Type t2) = t1 == t2
+ analyse (Var fun, [])
+ = case maybeUnfoldingTemplate (idUnfolding fun) of
+ Nothing -> Nothing
+ Just unf -> exprIsConApp_maybe unf
-cheapEqExpr _ _ = False
-\end{code}
+ analyse other = Nothing
+\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
-
- * free in type arguments,
- * free in the type of a binder,
-
-but not those that are free in the type of variable occurrence.
-
-\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
+@etaReduceExpr@ trys an eta reduction at the top level of a Core Expr.
-type InterestingVarFun = IdOrTyVar -> Bool -- True <=> interesting
-\end{code}
+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}
-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
+etaReduceExpr :: CoreExpr -> CoreExpr
+ -- ToDo: we should really check that we don't turn a non-bottom
+ -- lambda into a bottom variable. Sigh
-noVars :: FV
-noVars fv_cand in_scope = emptyVarSet
+etaReduceExpr expr@(Lam bndr body)
+ = check (reverse binders) body
+ where
+ (binders, body) = collectBinders expr
-oneVar :: IdOrTyVar -> FV
-oneVar var fv_cand in_scope
- | keep_it fv_cand in_scope var = unitVarSet var
- | otherwise = emptyVarSet
+ check [] body
+ | not (any (`elemVarSet` body_fvs) binders)
+ = body -- Success!
+ where
+ body_fvs = exprFreeVars body
-someVars :: IdOrTyVarSet -> FV
-someVars vars fv_cand in_scope
- = filterVarSet (keep_it fv_cand in_scope) vars
+ check (b : bs) (App fun arg)
+ | (varToCoreExpr b `cheapEqExpr` arg)
+ = check bs fun
-keep_it fv_cand in_scope var
- | var `elemVarSet` in_scope = False
- | fv_cand var = True
- | otherwise = False
+ check _ _ = expr -- Bale out
+etaReduceExpr expr = expr -- The common case
+\end{code}
+
-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
+\begin{code}
+exprEtaExpandArity :: CoreExpr -> Int -- The number of args the thing can be applied to
+ -- without doing much work
+-- This is used when eta expanding
+-- e ==> \xy -> e x y
+--
+-- It returns 1 (or more) to:
+-- case x of p -> \s -> ...
+-- because for I/O ish things we really want to get that \s to the top.
+-- We are prepared to evaluate x each time round the loop in order to get that
+-- Hence "generous" arity
+
+exprEtaExpandArity e
+ = go e `max` 0 -- Never go -ve!
where
- inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
+ go (Var v) = idArity v
+ go (App f (Type _)) = go f
+ go (App f a) | exprIsCheap a = go f - 1
+ go (Lam x e) | isId x = go e + 1
+ | otherwise = go e
+ go (Note n e) | ok_note n = go e
+ go (Case scrut _ alts)
+ | exprIsCheap scrut = min_zero [go rhs | (_,_,rhs) <- alts]
+ go (Let b e)
+ | all exprIsCheap (rhssOfBind b) = go e
+
+ go other = 0
+
+ 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
-addBndrs :: [CoreBndr] -> FV -> FV
-addBndrs bndrs fv = foldr addBndr fv bndrs
\end{code}
+%************************************************************************
+%* *
+\subsection{Equality}
+%* *
+%************************************************************************
+
+@cheapEqExpr@ is a cheap equality test which bales out fast!
+ True => definitely equal
+ False => may or may not be equal
+
\begin{code}
-expr_fvs :: CoreExpr -> FV
+cheapEqExpr :: Expr b -> Expr b -> Bool
-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)
+cheapEqExpr (Var v1) (Var v2) = v1==v2
+cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
+cheapEqExpr (Type t1) (Type t2) = t1 == t2
-expr_fvs (Case scrut bndr alts)
- = expr_fvs scrut `union` addBndr bndr (foldr (union. alt_fvs) noVars alts)
- where
- alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
+cheapEqExpr (App f1 a1) (App f2 a2)
+ = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
-expr_fvs (Let (NonRec bndr rhs) body)
- = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
+cheapEqExpr _ _ = False
-expr_fvs (Let (Rec pairs) body)
- = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
- where
- (bndrs,rhss) = unzip pairs
+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}
-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))
+eqExpr :: CoreExpr -> CoreExpr -> Bool
+ -- Works ok at more general type, but only needed at CoreExpr
+eqExpr e1 e2
+ = eq emptyVarEnv e1 e2
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
+ -- 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}
%************************************************************************
%* *
-\section{Substitution}
+\subsection{The size of an expression}
%* *
%************************************************************************
-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.
-
\begin{code}
-substExpr :: TyVarSubst -> IdSubst -- Substitution
- -> IdOrTyVarSet -- Superset of in-scope
- -> CoreExpr
- -> CoreExpr
-
-substExpr te ve in_scope expr = subst_expr (te, ve, in_scope) expr
-
-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
-
+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
+noteSize (TermUsg usg) = usg `seq` 1
+
+exprsSize = foldr ((+) . exprSize) 0
+
+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}
-Substituting in binders is a rather tricky part of the whole compiler.
+
+%************************************************************************
+%* *
+\subsection{Hashing}
+%* *
+%************************************************************************
\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)
- 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 Simplify.simplPrags
- (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)
--}
+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}
-
-
-
-
-
projects / ghc-hetmet.git / blobdiff