-- | Commonly useful utilites for manipulating the Core language
module CoreUtils (
-- * Constructing expressions
- mkSCC, mkCoerce, mkCoerceI,
+ mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
bindNonRec, needsCaseBinding,
mkAltExpr, mkPiType, mkPiTypes,
-- * Properties of expressions
exprType, coreAltType, coreAltsType,
- exprIsDupable, exprIsTrivial, exprIsCheap,
+ exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
exprIsHNF,exprOkForSpeculation, exprIsBig,
- exprIsConApp_maybe,
- exprBotStrictness_maybe,
+ exprIsConApp_maybe, exprIsBottom,
rhsIsStatic,
- -- * Arity and eta expansion
- -- exprIsBottom, Not used
- manifestArity, exprArity,
- exprEtaExpandArity, etaExpand,
-
-- * Expression and bindings size
coreBindsSize, exprSize,
hashExpr,
-- * Equality
- cheapEqExpr, tcEqExpr, tcEqExprX,
+ cheapEqExpr,
-- * Manipulating data constructors and types
applyTypeToArgs, applyTypeToArg,
#include "HsVersions.h"
-import StaticFlags ( opt_NoStateHack )
import CoreSyn
-import CoreFVs
import PprCore
import Var
import SrcLoc
-import VarSet
import VarEnv
import Name
import Module
import Coercion
import TyCon
import CostCentre
-import BasicTypes
import Unique
import Outputable
-import DynFlags
import TysPrim
import FastString
import Maybes
%* *
%************************************************************************
+mkNote removes redundant coercions, and SCCs where possible
+
+\begin{code}
+#ifdef UNUSED
+mkNote :: Note -> CoreExpr -> CoreExpr
+mkNote (SCC cc) expr = mkSCC cc expr
+mkNote InlineMe expr = mkInlineMe expr
+mkNote note expr = Note note expr
+#endif
+\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}
+-- | Wraps the given expression in an inlining hint unless the expression
+-- is trivial in some sense, so that doing so would usually hurt us
+mkInlineMe :: CoreExpr -> CoreExpr
+mkInlineMe (Var v) = Var v
+mkInlineMe e = Note InlineMe e
+\end{code}
+
\begin{code}
-- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
\begin{code}
exprIsDupable :: CoreExpr -> Bool
-exprIsDupable (Type _) = True
-exprIsDupable (Var _) = True
-exprIsDupable (Lit lit) = litIsDupable lit
-exprIsDupable (Note _ e) = exprIsDupable e
-exprIsDupable (Cast e _) = exprIsDupable e
+exprIsDupable (Type _) = True
+exprIsDupable (Var _) = True
+exprIsDupable (Lit lit) = litIsDupable lit
+exprIsDupable (Note InlineMe _) = True
+exprIsDupable (Note _ e) = exprIsDupable e
+exprIsDupable (Cast e _) = exprIsDupable e
exprIsDupable expr
= go expr 0
where
because sharing will make sure it is only evaluated once.
\begin{code}
-exprIsCheap :: CoreExpr -> Bool
-exprIsCheap (Lit _) = True
-exprIsCheap (Type _) = True
-exprIsCheap (Var _) = True
-exprIsCheap (Note _ e) = exprIsCheap e
-exprIsCheap (Cast e _) = exprIsCheap e
-exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
-exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
- and [exprIsCheap rhs | (_,_,rhs) <- alts]
+exprIsCheap' :: (Id -> Bool) -> CoreExpr -> Bool
+exprIsCheap' _ (Lit _) = True
+exprIsCheap' _ (Type _) = True
+exprIsCheap' _ (Var _) = True
+exprIsCheap' _ (Note InlineMe _) = True
+exprIsCheap' is_conlike (Note _ e) = exprIsCheap' is_conlike e
+exprIsCheap' is_conlike (Cast e _) = exprIsCheap' is_conlike e
+exprIsCheap' is_conlike (Lam x e) = isRuntimeVar x
+ || exprIsCheap' is_conlike e
+exprIsCheap' is_conlike (Case e _ _ alts) = exprIsCheap' is_conlike e &&
+ and [exprIsCheap' is_conlike 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
+exprIsCheap' is_conlike (Let (NonRec x _) e)
+ | isUnLiftedType (idType x) = exprIsCheap' is_conlike e
| otherwise = False
-- strict lets always have cheap right hand sides,
-- and do no allocation.
-exprIsCheap other_expr -- Applications and variables
+exprIsCheap' is_conlike other_expr -- Applications and variables
= go other_expr []
where
-- Accumulate value arguments, then decide
go (Var _) [] = True -- Just a type application of a variable
-- (f t1 t2 t3) counts as WHNF
go (Var f) args
- = case globalIdDetails f of
- RecordSelId {} -> go_sel args
- ClassOpId _ -> go_sel args
- PrimOpId op -> go_primop op args
+ = case idDetails f of
+ RecSelId {} -> go_sel args
+ ClassOpId _ -> go_sel args
+ PrimOpId op -> go_primop op args
- DataConWorkId _ -> go_pap args
- _ | length args < idArity f -> go_pap args
+ _ | is_conlike f -> go_pap args
+ | length args < idArity f -> go_pap args
_ -> isBottomingId f
-- Application of a function which
-- We'll put up with one constructor application, but not dozens
--------------
- go_primop op args = primOpIsCheap op && all exprIsCheap args
+ go_primop op args = primOpIsCheap op && all (exprIsCheap' is_conlike) args
-- 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
--------------
- go_sel [arg] = exprIsCheap arg -- I'm experimenting with making record selection
+ go_sel [arg] = exprIsCheap' is_conlike arg -- I'm experimenting with making record selection
go_sel _ = False -- look cheap, so we will substitute it inside a
-- lambda. Particularly for dictionary field selection.
-- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
-- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
+
+exprIsCheap :: CoreExpr -> Bool
+exprIsCheap = exprIsCheap' isDataConWorkId
+
+exprIsExpandable :: CoreExpr -> Bool
+exprIsExpandable = exprIsCheap' isConLikeId
\end{code}
\begin{code}
exprOkForSpeculation (Cast e _) = exprOkForSpeculation e
exprOkForSpeculation other_expr
= case collectArgs other_expr of
- (Var f, args) -> spec_ok (globalIdDetails f) args
+ (Var f, args) -> spec_ok (idDetails f) args
_ -> False
where
\end{code}
\begin{code}
-{- Never used -- omitting
-- | True of expressions that are guaranteed to diverge upon execution
-exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
+exprIsBottom :: CoreExpr -> Bool
exprIsBottom e = go 0 e
where
-- n is the number of args
idAppIsBottom :: Id -> Int -> Bool
idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
--}
\end{code}
\begin{code}
exprIsConApp_maybe (Note _ expr)
= exprIsConApp_maybe expr
- -- We ignore all notes. For example,
+ -- We ignore InlineMe notes in case we have
+ -- x = __inline_me__ (a,b)
+ -- All part of making sure that INLINE pragmas never hurt
+ -- Marcin tripped on this one when making dictionaries more inlinable
+ --
+ -- In fact, we ignore all notes. For example,
-- case _scc_ "foo" (C a b) of
-- C a b -> e
-- should be optimised away, but it will be only if we look
-- we are effectively duplicating the unfolding
analyse (Var fun, [])
| let unf = idUnfolding fun,
- isCheapUnfolding unf
+ isExpandableUnfolding unf
= exprIsConApp_maybe (unfoldingTemplate unf)
analyse _ = Nothing
%************************************************************************
%* *
-\subsection{Eta reduction and expansion}
-%* *
-%************************************************************************
-
-\begin{code}
--- ^ The Arity returned is the number of value args the
--- expression can be applied to without doing much work
-exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
--- exprEtaExpandArity is used when eta expanding
--- e ==> \xy -> e x y
-exprEtaExpandArity dflags e
- = applyStateHack (exprType e) (arityDepth (arityType dicts_cheap e))
- where
- dicts_cheap = dopt Opt_DictsCheap dflags
-
-exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
--- A cheap and cheerful function that identifies bottoming functions
--- and gives them a suitable strictness signatures. It's used during
--- float-out
-exprBotStrictness_maybe e
- = case arityType False e of
- AT _ ATop -> Nothing
- AT a ABot -> Just (a, mkStrictSig (mkTopDmdType (replicate a topDmd) BotRes))
-\end{code}
-
-
-Note [Definition of arity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-The "arity" of an expression 'e' is n if
- applying 'e' to *fewer* than n *value* arguments
- converges rapidly
-
-Or, to put it another way
-
- there is no work lost in duplicating the partial
- application (e x1 .. x(n-1))
-
-In the divegent case, no work is lost by duplicating because if the thing
-is evaluated once, that's the end of the program.
-
-Or, to put it another way, in any context C
-
- C[ (\x1 .. xn. e x1 .. xn) ]
- is as efficient as
- C[ e ]
-
-
-It's all a bit more subtle than it looks:
-
-Note [Arity of case expressions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We treat the arity of
- case x of p -> \s -> ...
-as 1 (or more) 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.
-
-This isn't really right in the presence of seq. Consider
- f = \x -> case x of
- True -> \y -> x+y
- False -> \y -> x-y
-Can we eta-expand here? At first the answer looks like "yes of course", but
-consider
- (f bot) `seq` 1
-This should diverge! But if we eta-expand, it won't. Again, we ignore this
-"problem", because being scrupulous would lose an important transformation for
-many programs.
-
-
-1. Note [One-shot lambdas]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider one-shot lambdas
- let x = expensive in \y z -> E
-We want this to have arity 1 if the \y-abstraction is a 1-shot lambda.
-
-3. Note [Dealing with bottom]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- f = \x -> error "foo"
-Here, arity 1 is fine. But if it is
- f = \x -> case x of
- True -> error "foo"
- False -> \y -> x+y
-then we want to get arity 2. Technically, this isn't quite right, because
- (f True) `seq` 1
-should diverge, but it'll converge if we eta-expand f. Nevertheless, we
-do so; it improves some programs significantly, and increasing convergence
-isn't a bad thing. Hence the ABot/ATop in ArityType.
-
-
-4. Note [Newtype arity]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Non-recursive newtypes are transparent, and should not get in the way.
-We do (currently) eta-expand recursive newtypes too. So if we have, say
-
- newtype T = MkT ([T] -> Int)
-
-Suppose we have
- e = coerce T f
-where f has arity 1. Then: etaExpandArity e = 1;
-that is, etaExpandArity looks through the coerce.
-
-When we eta-expand e to arity 1: eta_expand 1 e T
-we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
-
-HOWEVER, note that if you use coerce bogusly you can ge
- coerce Int negate
-And since negate has arity 2, you might try to eta expand. But you can't
-decopose Int to a function type. Hence the final case in eta_expand.
-
-
-Note [The state-transformer hack]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
- f = e
-where e has arity n. Then, if we know from the context that f has
-a usage type like
- t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...
-then we can expand the arity to m. This usage type says that
-any application (x e1 .. en) will be applied to uniquely to (m-n) more args
-Consider f = \x. let y = <expensive>
- in case x of
- True -> foo
- False -> \(s:RealWorld) -> e
-where foo has arity 1. Then we want the state hack to
-apply to foo too, so we can eta expand the case.
-
-Then we expect that if f is applied to one arg, it'll be applied to two
-(that's the hack -- we don't really know, and sometimes it's false)
-See also Id.isOneShotBndr.
-
-\begin{code}
-applyStateHack :: Type -> Arity -> Arity
-applyStateHack ty arity -- Note [The state-transformer hack]
- | opt_NoStateHack = arity
- | otherwise = go ty arity
- where
- go :: Type -> Arity -> Arity
- go ty arity -- This case analysis should match that in eta_expand
- | Just (_, ty') <- splitForAllTy_maybe ty = go ty' arity
-
- | Just (tc,tys) <- splitTyConApp_maybe ty
- , Just (ty', _) <- instNewTyCon_maybe tc tys
- , not (isRecursiveTyCon tc) = go ty' arity
- -- Important to look through non-recursive newtypes, so that, eg
- -- (f x) where f has arity 2, f :: Int -> IO ()
- -- Here we want to get arity 1 for the result!
-
- | Just (arg,res) <- splitFunTy_maybe ty
- , arity > 0 || isStateHackType arg = 1 + go res (arity-1)
-
- | otherwise = WARN( arity > 0, ppr arity ) 0
-\end{code}
-
-
--------------------- Main arity code ----------------------------
-\begin{code}
--- If e has ArityType (AT as r), then the term 'e'
--- * Must be applied to at least (length as) *value* args
--- before doing any significant work
--- * It will not diverge before being applied to (length as)
--- value arguments
--- * If 'r' is ABot, then it guarantees to eventually diverge if
--- applied to enough arguments (perhaps more than (length as)
-
-data ArityType = AT Arity ArityRes
-data ArityRes = ATop -- Know nothing
- | ABot -- Diverges
-
-vanillaArityType :: ArityType
-vanillaArityType = AT 0 ATop -- Totally uninformative
-
-arityDepth :: ArityType -> Arity
-arityDepth (AT a _) = a
-
-incArity :: ArityType -> ArityType
-incArity (AT a r) = AT (a+1) r
-
-decArity :: ArityType -> ArityType
-decArity (AT 0 r) = AT 0 r
-decArity (AT a r) = AT (a-1) r
-
-andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case'
-andArityType (AT a1 ATop) (AT a2 ATop) = AT (a1 `min` a2) ATop
-andArityType (AT _ ABot) (AT a2 ATop) = AT a2 ATop
-andArityType (AT a1 ATop) (AT _ ABot) = AT a1 ATop
-andArityType (AT a1 ABot) (AT a2 ABot) = AT (a1 `max` a2) ABot
-
-trimArity :: Bool -> ArityType -> ArityType
--- We have something like (let x = E in b), where b has the given
--- arity type. Then
--- * If E is cheap we can push it inside as far as we like
--- * If b eventually diverges, we allow ourselves to push inside
--- arbitrarily, even though that is not quite right
-trimArity _cheap (AT a ABot) = AT a ABot
-trimArity True (AT a ATop) = AT a ATop
-trimArity False (AT _ ATop) = AT 0 ATop -- Bale out
-
----------------------------
-arityType :: Bool -> CoreExpr -> ArityType
-arityType _ (Var v)
- | Just strict_sig <- idNewStrictness_maybe v
- , (ds, res) <- splitStrictSig strict_sig
- , isBotRes res
- = AT (length ds) ABot -- Function diverges
- | otherwise
- = AT (idArity v) ATop
-
- -- Lambdas; increase arity
-arityType dicts_cheap (Lam x e)
- | isId x = incArity (arityType dicts_cheap e)
- | otherwise = arityType dicts_cheap e
-
- -- Applications; decrease arity
-arityType dicts_cheap (App fun (Type _))
- = arityType dicts_cheap fun
-arityType dicts_cheap (App fun arg )
- = trimArity (exprIsCheap arg) (decArity (arityType dicts_cheap fun))
-
- -- Case/Let; keep arity if either the expression is cheap
- -- or it's a 1-shot lambda
- -- The former is not really right for Haskell
- -- f x = case x of { (a,b) -> \y. e }
- -- ===>
- -- f x y = case x of { (a,b) -> e }
- -- The difference is observable using 'seq'
-arityType dicts_cheap (Case scrut _ _ alts)
- = trimArity (exprIsCheap scrut)
- (foldr1 andArityType [arityType dicts_cheap rhs | (_,_,rhs) <- alts])
-
-arityType dicts_cheap (Let b e)
- = trimArity (cheap_bind b) (arityType dicts_cheap e)
- where
- cheap_bind (NonRec b e) = is_cheap (b,e)
- cheap_bind (Rec prs) = all is_cheap prs
- is_cheap (b,e) = (dicts_cheap && isDictId b) || exprIsCheap e
- -- If the experimental -fdicts-cheap flag is on, we eta-expand through
- -- dictionary bindings. This improves arities. Thereby, it also
- -- means that full laziness is less prone to floating out the
- -- application of a function to its dictionary arguments, which
- -- can thereby lose opportunities for fusion. Example:
- -- foo :: Ord a => a -> ...
- -- foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
- -- -- So foo has arity 1
- --
- -- f = \x. foo dInt $ bar x
- --
- -- The (foo DInt) is floated out, and makes ineffective a RULE
- -- foo (bar x) = ...
- --
- -- One could go further and make exprIsCheap reply True to any
- -- dictionary-typed expression, but that's more work.
-
-arityType dicts_cheap (Note _ e) = arityType dicts_cheap e
-arityType dicts_cheap (Cast e _) = arityType dicts_cheap e
-arityType _ _ = vanillaArityType
-\end{code}
-
-
-\begin{code}
--- | @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 that:
---
--- > ty = exprType e = exprType e'
-etaExpand :: Arity -- ^ Result should have this number of value args
- -> [Unique] -- ^ Uniques to assign to the new binders
- -> CoreExpr -- ^ Expression to expand
- -> Type -- ^ Type of expression to expand
- -> CoreExpr
--- Note that SCCs are not treated specially. If we have
--- etaExpand 2 (\x -> scc "foo" e)
--- = (\xy -> (scc "foo" e) y)
--- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
-
-etaExpand n us expr ty
- | manifestArity expr >= n = expr -- The no-op case
- | otherwise = eta_expand n us expr ty
-
--- manifestArity sees how many leading value lambdas there are
-manifestArity :: CoreExpr -> Arity
-manifestArity (Lam v e) | isId v = 1 + manifestArity e
- | otherwise = manifestArity e
-manifestArity (Note _ e) = manifestArity e
-manifestArity (Cast e _) = manifestArity e
-manifestArity _ = 0
-
--- etaExpand deals with for-alls. For example:
--- etaExpand 1 E
--- where E :: forall a. a -> a
--- would return
--- (/\b. \y::a -> E b y)
---
--- It deals with coerces too, though they are now rare
--- so perhaps the extra code isn't worth it
-eta_expand :: Int -> [Unique] -> CoreExpr -> Type -> CoreExpr
-
-eta_expand n _ expr _
- | n == 0 -- Saturated, so nothing to do
- = expr
-
- -- Short cut for the case where there already
- -- is a lambda; no point in gratuitously adding more
-eta_expand n us (Lam v body) ty
- | isTyVar v
- = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
-
- | otherwise
- = Lam v (eta_expand (n-1) us body (funResultTy ty))
-
--- We used to have a special case that stepped inside Coerces here,
--- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
--- = Note note (eta_expand n us e ty)
--- BUT this led to an infinite loop
--- Example: newtype T = MkT (Int -> Int)
--- eta_expand 1 (coerce (Int->Int) e)
--- --> coerce (Int->Int) (eta_expand 1 T e)
--- by the bogus eqn
--- --> coerce (Int->Int) (coerce T
--- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
--- by the splitNewType_maybe case below
--- and round we go
-
-eta_expand n us expr ty
- = ASSERT2 (exprType expr `coreEqType` ty, ppr (exprType expr) $$ ppr ty)
- case splitForAllTy_maybe ty of {
- Just (tv,ty') ->
-
- Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty'))
- where
- lam_tv = setVarName tv (mkSysTvName uniq (fsLit "etaT"))
- -- Using tv as a base retains its tyvar/covar-ness
- (uniq:us2) = us
- ; Nothing ->
-
- case splitFunTy_maybe ty of {
- Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
- where
- arg1 = mkSysLocal (fsLit "eta") uniq arg_ty
- (uniq:us2) = us
-
- ; Nothing ->
-
- -- Given this:
- -- newtype T = MkT ([T] -> Int)
- -- Consider eta-expanding this
- -- eta_expand 1 e T
- -- We want to get
- -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
-
- case splitNewTypeRepCo_maybe ty of {
- Just(ty1,co) -> mkCoerce (mkSymCoercion co)
- (eta_expand n us (mkCoerce co expr) ty1) ;
- Nothing ->
-
- -- We have an expression of arity > 0, but its type isn't a function
- -- This *can* legitmately happen: e.g. coerce Int (\x. x)
- -- Essentially the programmer is playing fast and loose with types
- -- (Happy does this a lot). So we simply decline to eta-expand.
- -- Otherwise we'd end up with an explicit lambda having a non-function type
- expr
- }}}
-\end{code}
-
-exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
-It tells how many things the expression can be applied to before doing
-any work. It doesn't look inside cases, lets, etc. The idea is that
-exprEtaExpandArity will do the hard work, leaving something that's easy
-for exprArity to grapple with. In particular, Simplify uses exprArity to
-compute the ArityInfo for the Id.
-
-Originally I thought that it was enough just to look for top-level lambdas, but
-it isn't. I've seen this
-
- foo = PrelBase.timesInt
-
-We want foo to get arity 2 even though the eta-expander will leave it
-unchanged, in the expectation that it'll be inlined. But occasionally it
-isn't, because foo is blacklisted (used in a rule).
-
-Similarly, see the ok_note check in exprEtaExpandArity. So
- f = __inline_me (\x -> e)
-won't be eta-expanded.
-
-And in any case it seems more robust to have exprArity be a bit more intelligent.
-But note that (\x y z -> f x y z)
-should have arity 3, regardless of f's arity.
-
-Note [exprArity invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-exprArity has the following invariant:
- (exprArity e) = n, then manifestArity (etaExpand e n) = n
-
-That is, if exprArity says "the arity is n" then etaExpand really can get
-"n" manifest lambdas to the top.
-
-Why is this important? Because
- - In TidyPgm we use exprArity to fix the *final arity* of
- each top-level Id, and in
- - In CorePrep we use etaExpand on each rhs, so that the visible lambdas
- actually match that arity, which in turn means
- that the StgRhs has the right number of lambdas
-
-An alternative would be to do the eta-expansion in TidyPgm, at least
-for top-level bindings, in which case we would not need the trim_arity
-in exprArity. That is a less local change, so I'm going to leave it for today!
-
-
-\begin{code}
--- | An approximate, fast, version of 'exprEtaExpandArity'
-exprArity :: CoreExpr -> Arity
-exprArity e = go e
- where
- go (Var v) = idArity v
- go (Lam x e) | isId x = go e + 1
- | otherwise = go e
- go (Note _ e) = go e
- go (Cast e co) = trim_arity (go e) 0 (snd (coercionKind co))
- go (App e (Type _)) = go e
- go (App f a) | exprIsCheap a = (go f - 1) `max` 0
- -- NB: exprIsCheap a!
- -- f (fac x) does not have arity 2,
- -- even if f has arity 3!
- -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
- -- unknown, hence arity 0
- go _ = 0
-
- -- Note [exprArity invariant]
- trim_arity n a ty
- | n==a = a
- | Just (_, ty') <- splitForAllTy_maybe ty = trim_arity n a ty'
- | Just (_, ty') <- splitFunTy_maybe ty = trim_arity n (a+1) ty'
- | Just (ty',_) <- splitNewTypeRepCo_maybe ty = trim_arity n a ty'
- | otherwise = a
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Equality}
%* *
%************************************************************************
exprIsBig (Lit _) = False
exprIsBig (Var _) = False
exprIsBig (Type _) = False
-exprIsBig (Lam _ e) = exprIsBig e
exprIsBig (App f a) = exprIsBig f || exprIsBig a
exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!
exprIsBig _ = True
\end{code}
-\begin{code}
-tcEqExpr :: CoreExpr -> CoreExpr -> Bool
--- ^ A kind of shallow equality used in rule matching, so does
--- /not/ look through newtypes or predicate types
-
-tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
- where
- rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
-
-tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
-tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
-tcEqExprX _ (Lit lit1) (Lit lit2) = lit1 == lit2
-tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
-tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
-tcEqExprX env (Let (NonRec v1 r1) e1)
- (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
- && tcEqExprX (rnBndr2 env v1 v2) e1 e2
-tcEqExprX env (Let (Rec ps1) e1)
- (Let (Rec ps2) e2) = equalLength ps1 ps2
- && and (zipWith eq_rhs ps1 ps2)
- && tcEqExprX env' e1 e2
- where
- env' = foldl2 rn_bndr2 env ps2 ps2
- rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
- eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
-tcEqExprX env (Case e1 v1 t1 a1)
- (Case e2 v2 t2 a2) = tcEqExprX env e1 e2
- && tcEqTypeX env t1 t2
- && equalLength a1 a2
- && and (zipWith (eq_alt env') a1 a2)
- where
- env' = rnBndr2 env v1 v2
-
-tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
-tcEqExprX env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && tcEqExprX env e1 e2
-tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
-tcEqExprX _ _ _ = False
-
-eq_alt :: RnEnv2 -> CoreAlt -> CoreAlt -> Bool
-eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
-
-eq_note :: RnEnv2 -> Note -> Note -> Bool
-eq_note _ (SCC cc1) (SCC cc2) = cc1 == cc2
-eq_note _ (CoreNote s1) (CoreNote s2) = s1 == s2
-eq_note _ _ _ = False
-\end{code}
-
%************************************************************************
%* *
noteSize :: Note -> Int
noteSize (SCC cc) = cc `seq` 1
+noteSize InlineMe = 1
noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
varSize :: Var -> Int
-- This is a bit like CoreUtils.exprIsHNF, with the following differences:
-- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
--
--- b) (C x xs), where C is a contructor is updatable if the application is
+-- b) (C x xs), where C is a contructors is updatable if the application is
-- dynamic
--
-- c) don't look through unfolding of f in (f x).
is_static _ (Lit lit)
= case lit of
- MachLabel _ _ -> False
+ MachLabel _ _ _ -> False
_ -> True
-- A MachLabel (foreign import "&foo") in an argument
-- prevents a constructor application from being static. The
projects / ghc-hetmet.git / blobdiff