X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=379da8aef3c4cc44bc60ce53385b5f8b416b8319;hp=415f5f73d805c093b8fdacb9fa34abe8c8ce9df0;hb=4bc25e8c30559b7a6a87b39afcc79340ae778788;hpb=d95ce839533391e7118257537044f01cbb1d6694 diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 415f5f7..379da8a 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -16,7 +16,7 @@ Utility functions on @Core@ syntax -- | Commonly useful utilites for manipulating the Core language module CoreUtils ( -- * Constructing expressions - mkSCC, mkCoerce, mkCoerceI, + mkInlineMe, mkSCC, mkCoerce, mkCoerceI, bindNonRec, needsCaseBinding, mkAltExpr, mkPiType, mkPiTypes, @@ -25,17 +25,11 @@ module CoreUtils ( -- * 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, @@ -43,7 +37,7 @@ module CoreUtils ( hashExpr, -- * Equality - cheapEqExpr, tcEqExpr, tcEqExprX, + cheapEqExpr, -- * Manipulating data constructors and types applyTypeToArgs, applyTypeToArg, @@ -52,13 +46,10 @@ module CoreUtils ( #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 @@ -75,10 +66,8 @@ import Type import Coercion import TyCon import CostCentre -import BasicTypes import Unique import Outputable -import DynFlags import TysPrim import FastString import Maybes @@ -175,6 +164,46 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty %* * %************************************************************************ +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 @@ -383,11 +412,12 @@ exprIsTrivial _ = False \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 @@ -430,26 +460,28 @@ 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 (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 @@ -459,13 +491,13 @@ exprIsCheap other_expr -- Applications and variables 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 @@ -482,18 +514,24 @@ exprIsCheap other_expr -- Applications and variables -- 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} @@ -539,7 +577,7 @@ exprOkForSpeculation (Note _ e) = exprOkForSpeculation e 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 @@ -580,9 +618,8 @@ isDivOp _ = False \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 @@ -598,7 +635,6 @@ exprIsBottom e = go 0 e idAppIsBottom :: Id -> Int -> Bool idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args --} \end{code} \begin{code} @@ -845,7 +881,12 @@ exprIsConApp_maybe (Note (BinaryTickBox {}) expr) 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 @@ -863,7 +904,7 @@ exprIsConApp_maybe expr = analyse (collectArgs expr) -- we are effectively duplicating the unfolding analyse (Var fun, []) | let unf = idUnfolding fun, - isCheapUnfolding unf + isExpandableUnfolding unf = exprIsConApp_maybe (unfoldingTemplate unf) analyse _ = Nothing @@ -873,449 +914,6 @@ exprIsConApp_maybe expr = analyse (collectArgs expr) %************************************************************************ %* * -\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 = - 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} %* * %************************************************************************ @@ -1345,60 +943,12 @@ exprIsBig :: Expr b -> Bool 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} - %************************************************************************ %* * @@ -1425,6 +975,7 @@ exprSize (Type t) = seqType t `seq` 1 noteSize :: Note -> Int noteSize (SCC cc) = cc `seq` 1 +noteSize InlineMe = 1 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations varSize :: Var -> Int @@ -1580,7 +1131,7 @@ rhsIsStatic :: PackageId -> CoreExpr -> Bool -- 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). @@ -1598,7 +1149,7 @@ rhsIsStatic _this_pkg rhs = is_static False rhs 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