\begin{code}
module CoreUtils (
- coreExprType, coreAltsType,
+ exprType, coreAltsType,
+
+ mkNote, mkInlineMe, mkSCC, mkCoerce,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
- exprIsValue,
- exprOkForSpeculation, exprIsBig, hashExpr,
- exprArity, exprEtaExpandArity,
+ exprIsValue,exprOkForSpeculation, exprIsBig,
+ exprArity,
+
+ idAppIsBottom, idAppIsCheap,
+
+ etaReduceExpr, exprEtaExpandArity,
+
+ hashExpr,
+
cheapEqExpr, eqExpr, applyTypeToArgs
) where
import GlaExts -- For `xori`
import CoreSyn
+import CoreFVs ( exprFreeVars )
import PprCore ( pprCoreExpr )
-import Var ( IdOrTyVar, isId, isTyVar )
+import Var ( isId, isTyVar )
import VarSet
import VarEnv
import Name ( isLocallyDefined, hashName )
-import Const ( Con(..), isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
- conType, hashCon
+import Literal ( Literal, hashLiteral, literalType )
+import PrimOp ( primOpOkForSpeculation, primOpIsCheap )
+import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo,
+ idArity, idName, idUnfolding, idInfo
)
-import PrimOp ( primOpOkForSpeculation, primOpStrictness )
-import Id ( Id, idType, setIdType, idUnique, idAppIsBottom,
- getIdArity, idName, isPrimitiveId_maybe,
- getIdSpecialisation, setIdSpecialisation,
- getInlinePragma, setInlinePragma,
- getIdUnfolding, setIdUnfolding, idInfo
+import IdInfo ( arityLowerBound, InlinePragInfo(..),
+ LBVarInfo(..),
+ IdFlavour(..),
+ appIsBottom
)
-import IdInfo ( arityLowerBound, InlinePragInfo(..), lbvarInfo, LBVarInfo(..) )
import Type ( Type, mkFunTy, mkForAllTy,
splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
- tidyTyVar, applyTys, isUnLiftedType
+ applyTys, isUnLiftedType
)
-import Demand ( isPrim, isLazy )
+import CostCentre ( CostCentre )
import Unique ( buildIdKey, augmentIdKey )
import Util ( zipWithEqual, mapAccumL )
import Outputable
%************************************************************************
\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 -- **! should take usage from e
-coreExprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (coreExprType e))
-coreExprType (Note other_note e) = coreExprType e
-coreExprType e@(Con con args) = ASSERT2( all (\ a -> case a of { Type ty -> isNotUsgTy ty; _ -> True }) args, ppr e)
- applyTypeToArgs e (conType con) args
-
-coreExprType (Lam binder expr)
- | isId binder = (case (lbvarInfo . idInfo) binder of
+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)
+ | isId binder = (case idLBVarInfo binder of
IsOneShotLambda -> mkUsgTy UsOnce
otherwise -> id) $
- idType binder `mkFunTy` coreExprType expr
- | isTyVar binder = mkForAllTy binder (coreExprType expr)
+ idType binder `mkFunTy` exprType expr
+ | isTyVar binder = mkForAllTy binder (exprType expr)
-coreExprType e@(App _ _)
+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}
\begin{code}
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 )
+ 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
Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
\end{code}
+
+
+%************************************************************************
+%* *
+\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.
+
+\begin{code}
+mkInlineMe e | exprIsTrivial e = e
+ | otherwise = Note InlineMe e
+\end{code}
+
+
+
+\begin{code}
+mkCoerce :: Type -> Type -> Expr b -> Expr b
+-- In (mkCoerce to_ty from_ty e), we require that from_ty = exprType e
+-- But exprType is defined in CoreUtils, so we don't check the assertion
+
+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 = 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{Figuring out things about expressions}
\begin{code}
exprIsTrivial (Type _) = True
+exprIsTrivial (Lit lit) = 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
\end{code}
\begin{code}
exprIsDupable (Type _) = True
-exprIsDupable (Con con args) = conIsDupable con &&
- all exprIsDupable args &&
- valArgCount args <= dupAppSize
-
+exprIsDupable (Var v) = True
+exprIsDupable (Lit lit) = True
exprIsDupable (Note _ e) = exprIsDupable e
-exprIsDupable expr = case collectArgs expr of
- (Var f, args) -> all exprIsDupable args && valArgCount args <= dupAppSize
- other -> 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
\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 other_expr -- look for manifest partial application
- = case collectArgs other_expr of
- (f, args) -> isPap f (valArgCount args) && all exprIsCheap args
-\end{code}
-
-\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 (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
-
- || n_val_args < arityLowerBound (getIdArity f)
-
-isPap fun n_val_args = False
+ | 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
\begin{code}
exprOkForSpeculation :: CoreExpr -> Bool
-exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
-exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
-
-exprOkForSpeculation (Con (Literal _) args) = True
-exprOkForSpeculation (Con (DataCon _) args) = True
- -- The strictness of the constructor has already
- -- been expressed by its "wrapper", so we don't need
- -- to take the arguments into account
-
-exprOkForSpeculation (Con (PrimOp op) args)
- = prim_op_ok_for_spec op args
-
-exprOkForSpeculation (App fun arg) -- Might be application of a primop
- = go fun [arg]
+exprOkForSpeculation (Lit _) = True
+exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
+exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
+exprOkForSpeculation other_expr
+ = go other_expr 0 True
where
- go (App fun arg) args = go fun (arg:args)
- go (Var v) args = case isPrimitiveId_maybe v of
- Just op -> prim_op_ok_for_spec op args
- Nothing -> False
- go other args = False
-
-exprOkForSpeculation other = False -- Conservative
-
-prim_op_ok_for_spec op args
- = primOpOkForSpeculation op &&
- and (zipWith ok (filter isValArg args) (fst (primOpStrictness op)))
- where
- ok arg demand | isLazy demand = True
- | otherwise = exprOkForSpeculation arg
+ 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}
@exprIsValue@ returns true for expressions that are certainly *already*
exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind
-- copying them
-exprIsValue (Var v) = isEvaldUnfolding (getIdUnfolding v)
+exprIsValue (Lit l) = True
exprIsValue (Lam b e) = isId b || exprIsValue e
exprIsValue (Note _ e) = exprIsValue e
-exprIsValue (Let _ e) = False
-exprIsValue (Case _ _ _) = False
-exprIsValue (Con con _) = isWHNFCon con
-exprIsValue e@(App _ _) = case collectArgs e of
- (Var v, args) -> fun_arity > valArgCount args
- where
- fun_arity = arityLowerBound (getIdArity v)
- _ -> False
+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}
\begin{code}
\end{code}
+%************************************************************************
+%* *
+\subsection{Eta reduction and expansion}
+%* *
+%************************************************************************
+
+@etaReduceExpr@ 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}
+etaReduceExpr :: CoreExpr -> CoreExpr
+ -- ToDo: we should really check that we don't turn a non-bottom
+ -- lambda into a bottom variable. Sigh
+
+etaReduceExpr 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
+
+etaReduceExpr expr = expr -- The common case
+\end{code}
+
+
\begin{code}
exprEtaExpandArity :: CoreExpr -> Int -- The number of args the thing can be applied to
-- without doing much work
-- We are prepared to evaluate x each time round the loop in order to get that
-- Hence "generous" arity
-exprEtaExpandArity (Var v) = arityLowerBound (getIdArity v)
-exprEtaExpandArity (Lam x e)
- | isId x = 1 + exprEtaExpandArity e
- | otherwise = exprEtaExpandArity e
-exprEtaExpandArity (Let bind body)
- | all exprIsCheap (rhssOfBind bind) = exprEtaExpandArity body
-exprEtaExpandArity (Case scrut _ alts)
- | exprIsCheap scrut = min_zero [exprEtaExpandArity rhs | (_,_,rhs) <- alts]
-
-exprEtaExpandArity (Note note e)
- | ok_note note = exprEtaExpandArity e
+exprEtaExpandArity e
+ = go e
where
+ go (Var v) = idArity v
+ go (App f (Type _)) = go f
+ go (App f a) | exprIsCheap a = (go f - 1) `max` 0 -- Never go -ve!
+ 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
-
-exprEtaExpandArity other = 0 -- Could do better for applications
+ -- 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
\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 (Con _ args) = any exprIsBig args
exprIsBig other = True
\end{code}
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)
\begin{code}
hashExpr :: CoreExpr -> Int
-hashExpr e = abs (hash_expr e)
- -- Negative numbers kill UniqFM
+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 (App f e) = hash_expr f * fast_hash_expr e
hash_expr (Var v) = hashId v
-hash_expr (Con con args) = foldr ((+) . fast_hash_expr) (hashCon con) args
+hash_expr (Lit lit) = hashLiteral lit
hash_expr (Lam b _) = hashId b
-hash_expr (Type t) = trace "hash_expr: type" 0 -- Shouldn't happen
+hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
fast_hash_expr (Var v) = hashId v
-fast_hash_expr (Con con args) = fast_hash_args args con
+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 = 0
-
-fast_hash_args [] con = hashCon con
-fast_hash_args (Type t : args) con = fast_hash_args args con
-fast_hash_args (arg : args) con = fast_hash_expr arg
+fast_hash_expr other = 1
hashId :: Id -> Int
hashId id = hashName (idName id)
projects / ghc-hetmet.git / blobdiff