{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 Arity and eta expansion -} {-# LANGUAGE CPP #-} -- | Arity and eta expansion module GHC.Core.Opt.Arity ( -- Finding arity manifestArity, joinRhsArity, exprArity , findRhsArity, cheapArityType , ArityOpts(..) -- ** Eta expansion , exprEtaExpandArity, etaExpand, etaExpandAT -- ** Eta reduction , tryEtaReduce -- ** ArityType , ArityType, mkBotArityType , arityTypeArity, idArityType -- ** Bottoming things , exprIsDeadEnd, exprBotStrictness_maybe, arityTypeBotSigs_maybe -- ** typeArity and the state hack , typeArity, typeOneShots, typeOneShot , isOneShotBndr , isStateHackType -- * Lambdas , zapLamBndrs -- ** Join points , etaExpandToJoinPoint, etaExpandToJoinPointRule -- ** Coercions and casts , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg , pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo ) where import GHC.Prelude import GHC.Core import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.DataCon import GHC.Core.TyCon ( tyConArity ) import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc ) import GHC.Core.Predicate ( isDictTy, isEvVar, isCallStackPredTy, isCallStackTy ) import GHC.Core.Multiplicity -- We have two sorts of substitution: -- GHC.Core.Subst.Subst, and GHC.Core.TyCo.Subst -- Both have substTy, substCo Hence need for qualification import GHC.Core.Subst as Core import GHC.Core.Type as Type import GHC.Core.Coercion as Type import GHC.Core.TyCo.Compare( eqType ) import GHC.Types.Demand import GHC.Types.Cpr( CprSig, mkCprSig, botCpr ) import GHC.Types.Id import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Tickish import GHC.Builtin.Types.Prim import GHC.Builtin.Uniques import GHC.Data.FastString import GHC.Data.Graph.UnVar import GHC.Data.Pair import GHC.Utils.GlobalVars( unsafeHasNoStateHack ) import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import Data.Maybe( isJust ) {- ************************************************************************ * * manifestArity and exprArity * * ************************************************************************ 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. -} manifestArity :: CoreExpr -> Arity -- ^ manifestArity sees how many leading value lambdas there are, -- after looking through casts manifestArity :: CoreExpr -> Int manifestArity (Lam TyVar v CoreExpr e) | TyVar -> Bool isId TyVar v = Int 1 Int -> Int -> Int forall a. Num a => a -> a -> a + CoreExpr -> Int manifestArity CoreExpr e | Bool otherwise = CoreExpr -> Int manifestArity CoreExpr e manifestArity (Tick CoreTickish t CoreExpr e) | Bool -> Bool not (CoreTickish -> Bool forall (pass :: TickishPass). GenTickish pass -> Bool tickishIsCode CoreTickish t) = CoreExpr -> Int manifestArity CoreExpr e manifestArity (Cast CoreExpr e Coercion _) = CoreExpr -> Int manifestArity CoreExpr e manifestArity CoreExpr _ = Int 0 joinRhsArity :: CoreExpr -> JoinArity -- Join points are supposed to have manifestly-visible -- lambdas at the top: no ticks, no casts, nothing -- Moreover, type lambdas count in JoinArity -- NB: For non-recursive bindings, the join arity of the binding may actually be -- less that the number of manifestly-visible lambdas. -- See Note [Join arity prediction based on joinRhsArity] in GHC.Core.Opt.OccurAnal joinRhsArity :: CoreExpr -> Int joinRhsArity (Lam TyVar _ CoreExpr e) = Int 1 Int -> Int -> Int forall a. Num a => a -> a -> a + CoreExpr -> Int joinRhsArity CoreExpr e joinRhsArity CoreExpr _ = Int 0 --------------- exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig, CprSig) -- A cheap and cheerful function that identifies bottoming functions -- and gives them a suitable strictness and CPR signatures. -- It's used during float-out exprBotStrictness_maybe :: CoreExpr -> Maybe (Int, DmdSig, CprSig) exprBotStrictness_maybe CoreExpr e = SafeArityType -> Maybe (Int, DmdSig, CprSig) arityTypeBotSigs_maybe (HasDebugCallStack => CoreExpr -> SafeArityType CoreExpr -> SafeArityType cheapArityType CoreExpr e) arityTypeBotSigs_maybe :: ArityType -> Maybe (Arity, DmdSig, CprSig) -- Arity of a divergent function arityTypeBotSigs_maybe :: SafeArityType -> Maybe (Int, DmdSig, CprSig) arityTypeBotSigs_maybe (AT [ATLamInfo] lams Divergence div) | Divergence -> Bool isDeadEndDiv Divergence div = (Int, DmdSig, CprSig) -> Maybe (Int, DmdSig, CprSig) forall a. a -> Maybe a Just ( Int arity , Int -> Divergence -> DmdSig mkVanillaDmdSig Int arity Divergence botDiv , Int -> Cpr -> CprSig mkCprSig Int arity Cpr botCpr) | Bool otherwise = Maybe (Int, DmdSig, CprSig) forall a. Maybe a Nothing where arity :: Int arity = [ATLamInfo] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [ATLamInfo] lams {- Note [exprArity for applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we come to an application we check that the arg is trivial. eg f (fac x) does not have arity 2, even if f has arity 3! * We require that is trivial rather merely cheap. Suppose f has arity 2. Then f (Just y) has arity 0, because if we gave it arity 1 and then inlined f we'd get let v = Just y in \w. <f-body> which has arity 0. And we try to maintain the invariant that we don't have arity decreases. * The `max 0` is important! (\x y -> f x) has arity 2, even if f is unknown, hence arity 0 ************************************************************************ * * typeArity and the "state hack" * * ********************************************************************* -} typeArity :: Type -> Arity -- ^ (typeArity ty) says how many arrows GHC can expose in 'ty', after -- looking through newtypes. More generally, (typeOneShots ty) returns -- ty's [OneShotInfo], based only on the type itself, using typeOneShot -- on the argument type to access the "state hack". typeArity :: Type -> Int typeArity = [OneShotInfo] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length ([OneShotInfo] -> Int) -> (Type -> [OneShotInfo]) -> Type -> Int forall b c a. (b -> c) -> (a -> b) -> a -> c . Type -> [OneShotInfo] typeOneShots typeOneShots :: Type -> [OneShotInfo] -- How many value arrows are visible in the type? -- We look through foralls, and newtypes -- See Note [Arity invariants for bindings] typeOneShots :: Type -> [OneShotInfo] typeOneShots Type ty = RecTcChecker -> Type -> [OneShotInfo] go RecTcChecker initRecTc Type ty where go :: RecTcChecker -> Type -> [OneShotInfo] go RecTcChecker rec_nts Type ty | Just (TyVar tcv, Type ty') <- Type -> Maybe (TyVar, Type) splitForAllTyCoVar_maybe Type ty = if TyVar -> Bool isCoVar TyVar tcv then TyVar -> OneShotInfo idOneShotInfo TyVar tcv OneShotInfo -> [OneShotInfo] -> [OneShotInfo] forall a. a -> [a] -> [a] : RecTcChecker -> Type -> [OneShotInfo] go RecTcChecker rec_nts Type ty' else RecTcChecker -> Type -> [OneShotInfo] go RecTcChecker rec_nts Type ty' | Just (FunTyFlag _,Type _,Type arg,Type res) <- Type -> Maybe (FunTyFlag, Type, Type, Type) splitFunTy_maybe Type ty = Type -> OneShotInfo typeOneShot Type arg OneShotInfo -> [OneShotInfo] -> [OneShotInfo] forall a. a -> [a] -> [a] : RecTcChecker -> Type -> [OneShotInfo] go RecTcChecker rec_nts Type res | Just (TyCon tc,[Type] tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type]) Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe Type ty , Just (Type ty', Coercion _) <- TyCon -> [Type] -> Maybe (Type, Coercion) instNewTyCon_maybe TyCon tc [Type] tys , Just RecTcChecker rec_nts' <- RecTcChecker -> TyCon -> Maybe RecTcChecker checkRecTc RecTcChecker rec_nts TyCon tc -- See Note [Expanding newtypes and products] -- in GHC.Core.TyCon -- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes -- -- See Note [Newtype classes and eta expansion] -- (no longer required) = RecTcChecker -> Type -> [OneShotInfo] go RecTcChecker rec_nts' Type ty' -- 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! -- -- AND through a layer of recursive newtypes -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) | Bool otherwise = [] typeOneShot :: Type -> OneShotInfo typeOneShot :: Type -> OneShotInfo typeOneShot Type ty | Type -> Bool isStateHackType Type ty = OneShotInfo OneShotLam | Bool otherwise = OneShotInfo NoOneShotInfo -- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account -- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" idStateHackOneShotInfo :: Id -> OneShotInfo idStateHackOneShotInfo :: TyVar -> OneShotInfo idStateHackOneShotInfo TyVar id | Type -> Bool isStateHackType (TyVar -> Type idType TyVar id) = OneShotInfo OneShotLam | Bool otherwise = TyVar -> OneShotInfo idOneShotInfo TyVar id -- | Returns whether the lambda associated with the 'Id' is -- certainly applied at most once -- This one is the "business end", called externally. -- It works on type variables as well as Ids, returning True -- Its main purpose is to encapsulate the Horrible State Hack -- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" isOneShotBndr :: Var -> Bool isOneShotBndr :: TyVar -> Bool isOneShotBndr TyVar var | TyVar -> Bool isTyVar TyVar var = Bool True | OneShotInfo OneShotLam <- TyVar -> OneShotInfo idStateHackOneShotInfo TyVar var = Bool True | Bool otherwise = Bool False isStateHackType :: Type -> Bool isStateHackType :: Type -> Bool isStateHackType Type ty | Bool unsafeHasNoStateHack -- Switch off with -fno-state-hack = Bool False | Bool otherwise = case Type -> Maybe TyCon tyConAppTyCon_maybe Type ty of Just TyCon tycon -> TyCon tycon TyCon -> TyCon -> Bool forall a. Eq a => a -> a -> Bool == TyCon statePrimTyCon Maybe TyCon _ -> Bool False -- This is a gross hack. It claims that -- every function over realWorldStatePrimTy is a one-shot -- function. This is pretty true in practice, and makes a big -- difference. For example, consider -- a `thenST` \ r -> ...E... -- The early full laziness pass, if it doesn't know that r is one-shot -- will pull out E (let's say it doesn't mention r) to give -- let lvl = E in a `thenST` \ r -> ...lvl... -- When `thenST` gets inlined, we end up with -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... -- and we don't re-inline E. -- -- It would be better to spot that r was one-shot to start with, but -- I don't want to rely on that. -- -- Another good example is in fill_in in PrelPack.hs. We should be able to -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. {- Note [Arity invariants for bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have the following invariants for let-bindings (1) In any binding f = e, idArity f <= typeArity (idType f) We enforce this with trimArityType, called in findRhsArity; see Note [Arity trimming]. Note that we enforce this only for /bindings/. We do /not/ insist that arityTypeArity (arityType e) <= typeArity (exprType e) because that is quite a bit more expensive to guaranteed; it would mean checking at every Cast in the recursive arityType, for example. (2) If typeArity (exprType e) = n, then manifestArity (etaExpand e n) = n That is, etaExpand can always expand as much as typeArity says (or less, of course). So the case analysis in etaExpand and in typeArity must match. Consequence: because of (1), if we eta-expand to (idArity f), we will end up with n manifest lambdas. (3) In any binding f = e, idArity f <= arityTypeArity (safeArityType (arityType e)) That is, we call safeArityType before attributing e's arityType to f. See Note [SafeArityType]. So we call safeArityType in findRhsArity. Suppose we have f :: Int -> Int -> Int f x y = x+y -- Arity 2 g :: F Int g = case <cond> of { True -> f |> co1 ; False -> g |> co2 } where F is a type family. Now, we can't eta-expand g to have arity 2, because etaExpand, which works off the /type/ of the expression (albeit looking through newtypes), doesn't know how to make an eta-expanded binding g = (\a b. case x of ...) |> co because it can't make up `co` or the types of `a` and `b`. So invariant (1) ensures that every binding has an arity that is no greater than the typeArity of the RHS; and invariant (2) ensures that etaExpand and handle what typeArity says. Why is this important? Because - In GHC.Iface.Tidy we use exprArity/manifestArity 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 a number of lambdas that precisely matches the arity. Note [Arity trimming] ~~~~~~~~~~~~~~~~~~~~~ Invariant (1) of Note [Arity invariants for bindings] is upheld by findRhsArity, which calls trimArityType to trim the ArityType to match the Arity of the binding. Failing to do so, and hence breaking invariant (1) led to #5441. How to trim? If we end in topDiv, it's easy. But we must take great care with dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"), we'll get \??.⊥. We absolutely must not trim that to \?.⊥, because that claims that ((\x y. error "urk") |> co) diverges when given one argument, which it absolutely does not. And Bad Things happen if we think something returns bottom when it doesn't (#16066). So, if we need to trim a dead-ending arity type, switch (conservatively) to topDiv. Historical note: long ago, we unconditionally switched to topDiv when we encountered a cast, but that is far too conservative: see #5475 Note [Newtype classes and eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: this nasty special case is no longer required, because for newtype classes we don't use the class-op rule mechanism at all. See Note [Single-method classes] in GHC.Tc.TyCl.Instance. SLPJ May 2013 -------- Old out of date comments, just for interest ----------- We have to be careful when eta-expanding through newtypes. In general it's a good idea, but annoyingly it interacts badly with the class-op rule mechanism. Consider class C a where { op :: a -> a } instance C b => C [b] where op x = ... These translate to co :: forall a. (a->a) ~ C a $copList :: C b -> [b] -> [b] $copList d x = ... $dfList :: C b -> C [b] {-# DFunUnfolding = [$copList] #-} $dfList d = $copList d |> co@[b] Now suppose we have: dCInt :: C Int blah :: [Int] -> [Int] blah = op ($dfList dCInt) Now we want the built-in op/$dfList rule will fire to give blah = $copList dCInt But with eta-expansion 'blah' might (and in #3772, which is slightly more complicated, does) turn into blah = op (\eta. ($dfList dCInt |> sym co) eta) and now it is *much* harder for the op/$dfList rule to fire, because exprIsConApp_maybe won't hold of the argument to op. I considered trying to *make* it hold, but it's tricky and I gave up. The test simplCore/should_compile/T3722 is an excellent example. -------- End of old out of date comments, just for interest ----------- -} {- ******************************************************************** * * Zapping lambda binders * * ********************************************************************* -} zapLamBndrs :: FullArgCount -> [Var] -> [Var] -- If (\xyz. t) appears under-applied to only two arguments, -- we must zap the occ-info on x,y, because they appear (in 't') under the \z. -- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal -- -- NB: both `arg_count` and `bndrs` include both type and value args/bndrs zapLamBndrs :: Int -> [TyVar] -> [TyVar] zapLamBndrs Int arg_count [TyVar] bndrs | Bool no_need_to_zap = [TyVar] bndrs | Bool otherwise = Int -> [TyVar] -> [TyVar] zap_em Int arg_count [TyVar] bndrs where no_need_to_zap :: Bool no_need_to_zap = (TyVar -> Bool) -> [TyVar] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all TyVar -> Bool isOneShotBndr (Int -> [TyVar] -> [TyVar] forall a. Int -> [a] -> [a] drop Int arg_count [TyVar] bndrs) zap_em :: FullArgCount -> [Var] -> [Var] zap_em :: Int -> [TyVar] -> [TyVar] zap_em Int 0 [TyVar] bs = [TyVar] bs zap_em Int _ [] = [] zap_em Int n (TyVar b:[TyVar] bs) | TyVar -> Bool isTyVar TyVar b = TyVar b TyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] : Int -> [TyVar] -> [TyVar] zap_em (Int nInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) [TyVar] bs | Bool otherwise = TyVar -> TyVar zapLamIdInfo TyVar b TyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] : Int -> [TyVar] -> [TyVar] zap_em (Int nInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) [TyVar] bs {- ********************************************************************* * * Computing the "arity" of an expression * * ************************************************************************ 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 divergent 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 [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. Note [Dealing with bottom] ~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC does some transformations that are technically unsound wrt bottom, because doing so improves arities... a lot! We describe them in this Note. The flag -fpedantic-bottoms (off by default) restore technically correct behaviour at the cots of efficiency. It's mostly to do with eta-expansion. Consider f = \x -> case x of True -> \s -> e1 False -> \s -> e2 This happens all the time when f :: Bool -> IO () In this case we do eta-expand, in order to get that \s to the top, and give f arity 2. This isn't really right in the presence of seq. Consider (f bot) `seq` 1 This should diverge! But if we eta-expand, it won't. We ignore this "problem" (unless -fpedantic-bottoms is on), because being scrupulous would lose an important transformation for many programs. (See #5587 for an example.) Consider also f = \x -> error "foo" Here, arity 1 is fine. But if it looks like this (see #22068) 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. So these two transformations aren't always the Right Thing, and we have several tickets reporting unexpected behaviour resulting from this transformation. So we try to limit it as much as possible: (1) Do NOT move a lambda outside a known-bottom case expression case undefined of { (a,b) -> \y -> e } This showed up in #5557 (2) Do NOT move a lambda outside a case unless (a) The scrutinee is ok-for-speculation, or (b) more liberally: the scrutinee is cheap (e.g. a variable), and -fpedantic-bottoms is not enforced (see #2915 for an example) Of course both (1) and (2) are readily defeated by disguising the bottoms. There also is an interaction with Note [Combining arity type with demand info], outlined in Wrinkle (CAD1). 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 decompose 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. Note [State hack and bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's a terrible idea to use the state hack on a bottoming function. Here's what happens (#2861): f :: String -> IO T f = \p. error "..." Eta-expand, using the state hack: f = \p. (\s. ((error "...") |> g1) s) |> g2 g1 :: IO T ~ (S -> (S,T)) g2 :: (S -> (S,T)) ~ IO T Extrude the g2 f' = \p. \s. ((error "...") |> g1) s f = f' |> (String -> g2) Discard args for bottoming function f' = \p. \s. ((error "...") |> g1 |> g3 g3 :: (S -> (S,T)) ~ (S,T) Extrude g1.g3 f'' = \p. \s. (error "...") f' = f'' |> (String -> S -> g1.g3) And now we can repeat the whole loop. Aargh! The bug is in applying the state hack to a function which then swallows the argument. This arose in another guise in #3959. Here we had catch# (throw exn >> return ()) Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()]. After inlining (>>) we get catch# (\_. throw {IO ()} exn) We must *not* eta-expand to catch# (\_ _. throw {...} exn) because 'catch#' expects to get a (# _,_ #) after applying its argument to a State#, not another function! In short, we use the state hack to allow us to push let inside a lambda, but not to introduce a new lambda. Note [ArityType] ~~~~~~~~~~~~~~~~ ArityType can be thought of as an abstraction of an expression. The ArityType AT [ (IsCheap, NoOneShotInfo) , (IsExpensive, OneShotLam) , (IsCheap, OneShotLam) ] Dunno) abstracts an expression like \x. let <expensive> in \y{os}. \z{os}. blah In general we have (AT lams div). Then * In lams :: [(Cost,OneShotInfo)] * The Cost flag describes the part of the expression down to the first (value) lambda. * The OneShotInfo flag gives the one-shot info on that lambda. * If 'div' is dead-ending ('isDeadEndDiv'), then application to 'length lams' arguments will surely diverge, similar to the situation with 'DmdType'. ArityType is the result of a compositional analysis on expressions, from which we can decide the real arity of the expression (extracted with function exprEtaExpandArity). We use the following notation: at ::= \p1..pn.div div ::= T | x | ⊥ p ::= (c o) c ::= X | C -- Expensive or Cheap o ::= ? | 1 -- NotOneShot or OneShotLam We may omit the \. if n = 0. And ⊥ stands for `AT [] botDiv` Here is an example demonstrating the notation: \(C?)(X1)(C1).T stands for AT [ (IsCheap,NoOneShotInfo) , (IsExpensive,OneShotLam) , (IsCheap,OneShotLam) ] topDiv See the 'Outputable' instance for more information. It's pretty simple. How can we use ArityType? Example: f = \x\y. let v = <expensive> in \s(one-shot) \t(one-shot). blah 'f' has arity type \(C?)(C?)(X1)(C1).T The one-shot-ness means we can, in effect, push that 'let' inside the \st, and expand to arity 4 Suppose f = \xy. x+y Then f :: \(C?)(C?).T f v :: \(C?).T f <expensive> :: \(X?).T Here is what the fields mean. If an arbitrary expression 'f' has ArityType 'at', then * If @at = AT [o1,..,on] botDiv@ (notation: \o1..on.⊥), then @f x1..xn@ definitely diverges. Partial applications to fewer than n args may *or may not* diverge. Ditto exnDiv. * If `f` has ArityType `at` we can eta-expand `f` to have (aritTypeOneShots at) arguments without losing sharing. This function checks that the either there are no expensive expressions, or the lambdas are one-shots. NB 'f' is an arbitrary expression, eg @f = g e1 e2@. This 'f' can have arity type @AT oss _@, with @length oss > 0@, only if e1 e2 are themselves cheap. * In both cases, @f@, @f x1@, ... @f x1 ... x(n-1)@ are definitely really functions, or bottom, but *not* casts from a data type, in at least one case branch. (If it's a function in one case branch but an unsafe cast from a data type in another, the program is bogus.) So eta expansion is dynamically ok; see Note [State hack and bottoming functions], the part about catch# Wrinkles * Wrinkle [Bottoming functions]: see function 'arityLam'. We treat bottoming functions as one-shot, because there is no point in floating work outside the lambda, and it's fine to float it inside. For example, this is fine (see test stranal/sigs/BottomFromInnerLambda) let x = <expensive> in \y. error (g x y) ==> \y. let x = <expensive> in error (g x y) Idea: perhaps we could enforce this invariant with data Arity Type = TopAT [(Cost, OneShotInfo)] | DivAT [Cost] Note [SafeArityType] ~~~~~~~~~~~~~~~~~~~~ The function safeArityType trims an ArityType to return a "safe" ArityType, for which we use a type synonym SafeArityType. It is "safe" in the sense that (arityTypeArity at) really reflects the arity of the expression, whereas a regular ArityType might have more lambdas in its [ATLamInfo] that the (cost-free) arity of the expression. For example \x.\y.let v = expensive in \z. blah has arityType = AT [C?, C?, X?, C?] Top But the expression actually has arity 2, not 4, because of the X. So safeArityType will trim it to (AT [C?, C?] Top), whose [ATLamInfo] now reflects the (cost-free) arity of the expression Why do we ever need an "unsafe" ArityType, such as the example above? Because its (cost-free) arity may increased by combineWithCallCards in findRhsArity. See Note [Combining arity type with demand info]. Thus the function `arityType` returns a regular "unsafe" ArityType, that goes deeply into the lambdas (including under IsExpensive). But that is very local; most ArityTypes are indeed "safe". We use the type synonym SafeArityType to indicate where we believe the ArityType is safe. -} -- | The analysis lattice of arity analysis. It is isomorphic to -- -- @ -- data ArityType' -- = AEnd Divergence -- | ALam OneShotInfo ArityType' -- @ -- -- Which is easier to display the Hasse diagram for: -- -- @ -- ALam OneShotLam at -- | -- AEnd topDiv -- | -- ALam NoOneShotInfo at -- | -- AEnd exnDiv -- | -- AEnd botDiv -- @ -- -- where the @at@ fields of @ALam@ are inductively subject to the same order. -- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2@. -- -- Why the strange Top element? -- See Note [Combining case branches: optimistic one-shot-ness] -- -- We rely on this lattice structure for fixed-point iteration in -- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType]. data ArityType -- See Note [ArityType] = AT ![ATLamInfo] !Divergence -- ^ `AT oss div` is an abstraction of the expression, which describes -- its lambdas, and how much work appears where. -- See Note [ArityType] for more information -- -- If `div` is dead-ending ('isDeadEndDiv'), then application to -- `length os` arguments will surely diverge, similar to the situation -- with 'DmdType'. deriving SafeArityType -> SafeArityType -> Bool (SafeArityType -> SafeArityType -> Bool) -> (SafeArityType -> SafeArityType -> Bool) -> Eq SafeArityType forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: SafeArityType -> SafeArityType -> Bool == :: SafeArityType -> SafeArityType -> Bool $c/= :: SafeArityType -> SafeArityType -> Bool /= :: SafeArityType -> SafeArityType -> Bool Eq type ATLamInfo = (Cost,OneShotInfo) -- ^ Info about one lambda in an ArityType -- See Note [ArityType] type SafeArityType = ArityType -- See Note [SafeArityType] data Cost = IsCheap | IsExpensive deriving( Cost -> Cost -> Bool (Cost -> Cost -> Bool) -> (Cost -> Cost -> Bool) -> Eq Cost forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: Cost -> Cost -> Bool == :: Cost -> Cost -> Bool $c/= :: Cost -> Cost -> Bool /= :: Cost -> Cost -> Bool Eq ) allCosts :: (a -> Cost) -> [a] -> Cost allCosts :: forall a. (a -> Cost) -> [a] -> Cost allCosts a -> Cost f [a] xs = (a -> Cost -> Cost) -> Cost -> [a] -> Cost forall a b. (a -> b -> b) -> b -> [a] -> b forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (Cost -> Cost -> Cost addCost (Cost -> Cost -> Cost) -> (a -> Cost) -> a -> Cost -> Cost forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Cost f) Cost IsCheap [a] xs addCost :: Cost -> Cost -> Cost addCost :: Cost -> Cost -> Cost addCost Cost IsCheap Cost IsCheap = Cost IsCheap addCost Cost _ Cost _ = Cost IsExpensive -- | This is the BNF of the generated output: -- -- @ -- @ -- -- We format -- @AT [o1,..,on] topDiv@ as @\o1..on.T@ and -- @AT [o1,..,on] botDiv@ as @\o1..on.⊥@, respectively. -- More concretely, @AT [NOI,OS,OS] topDiv@ is formatted as @\?11.T@. -- If the one-shot info is empty, we omit the leading @\.@. instance Outputable ArityType where ppr :: SafeArityType -> SDoc ppr (AT [ATLamInfo] oss Divergence div) | [ATLamInfo] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [ATLamInfo] oss = Divergence -> SDoc forall {doc}. IsLine doc => Divergence -> doc pp_div Divergence div | Bool otherwise = Char -> SDoc forall doc. IsLine doc => Char -> doc char Char '\\' SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <> [SDoc] -> SDoc forall doc. IsLine doc => [doc] -> doc hcat ((ATLamInfo -> SDoc) -> [ATLamInfo] -> [SDoc] forall a b. (a -> b) -> [a] -> [b] map ATLamInfo -> SDoc forall {doc}. IsLine doc => ATLamInfo -> doc pp_os [ATLamInfo] oss) SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <> SDoc forall doc. IsLine doc => doc dot SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <> Divergence -> SDoc forall {doc}. IsLine doc => Divergence -> doc pp_div Divergence div where pp_div :: Divergence -> doc pp_div Divergence Diverges = Char -> doc forall doc. IsLine doc => Char -> doc char Char '⊥' pp_div Divergence ExnOrDiv = Char -> doc forall doc. IsLine doc => Char -> doc char Char 'x' pp_div Divergence Dunno = Char -> doc forall doc. IsLine doc => Char -> doc char Char 'T' pp_os :: ATLamInfo -> doc pp_os (Cost IsCheap, OneShotInfo OneShotLam) = String -> doc forall doc. IsLine doc => String -> doc text String "(C1)" pp_os (Cost IsExpensive, OneShotInfo OneShotLam) = String -> doc forall doc. IsLine doc => String -> doc text String "(X1)" pp_os (Cost IsCheap, OneShotInfo NoOneShotInfo) = String -> doc forall doc. IsLine doc => String -> doc text String "(C?)" pp_os (Cost IsExpensive, OneShotInfo NoOneShotInfo) = String -> doc forall doc. IsLine doc => String -> doc text String "(X?)" mkBotArityType :: [OneShotInfo] -> ArityType mkBotArityType :: [OneShotInfo] -> SafeArityType mkBotArityType [OneShotInfo] oss = [ATLamInfo] -> Divergence -> SafeArityType AT [(Cost IsCheap,OneShotInfo os) | OneShotInfo os <- [OneShotInfo] oss] Divergence botDiv botArityType :: ArityType botArityType :: SafeArityType botArityType = [OneShotInfo] -> SafeArityType mkBotArityType [] topArityType :: ArityType topArityType :: SafeArityType topArityType = [ATLamInfo] -> Divergence -> SafeArityType AT [] Divergence topDiv -- | The number of value args for the arity type arityTypeArity :: SafeArityType -> Arity arityTypeArity :: SafeArityType -> Int arityTypeArity (AT [ATLamInfo] lams Divergence _) = [ATLamInfo] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [ATLamInfo] lams arityTypeOneShots :: SafeArityType -> [OneShotInfo] -- Returns a list only as long as the arity should be arityTypeOneShots :: SafeArityType -> [OneShotInfo] arityTypeOneShots (AT [ATLamInfo] lams Divergence _) = (ATLamInfo -> OneShotInfo) -> [ATLamInfo] -> [OneShotInfo] forall a b. (a -> b) -> [a] -> [b] map ATLamInfo -> OneShotInfo forall a b. (a, b) -> b snd [ATLamInfo] lams safeArityType :: ArityType -> SafeArityType -- ^ Assuming this ArityType is all we know, find the arity of -- the function, and trim the argument info (and Divergence) -- to match that arity. See Note [SafeArityType] safeArityType :: SafeArityType -> SafeArityType safeArityType at :: SafeArityType at@(AT [ATLamInfo] lams Divergence _) = case Int -> Cost -> [ATLamInfo] -> Maybe Int go Int 0 Cost IsCheap [ATLamInfo] lams of Maybe Int Nothing -> SafeArityType at -- No trimming needed Just Int ar -> [ATLamInfo] -> Divergence -> SafeArityType AT (Int -> [ATLamInfo] -> [ATLamInfo] forall a. Int -> [a] -> [a] take Int ar [ATLamInfo] lams) Divergence topDiv where go :: Arity -> Cost -> [(Cost,OneShotInfo)] -> Maybe Arity go :: Int -> Cost -> [ATLamInfo] -> Maybe Int go Int _ Cost _ [] = Maybe Int forall a. Maybe a Nothing go Int ar Cost ch1 ((Cost ch2,OneShotInfo os):[ATLamInfo] lams) = case (Cost ch1 Cost -> Cost -> Cost `addCost` Cost ch2, OneShotInfo os) of (Cost IsExpensive, OneShotInfo NoOneShotInfo) -> Int -> Maybe Int forall a. a -> Maybe a Just Int ar (Cost ch, OneShotInfo _) -> Int -> Cost -> [ATLamInfo] -> Maybe Int go (Int arInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) Cost ch [ATLamInfo] lams infixl 2 `trimArityType` trimArityType :: Arity -> ArityType -> ArityType -- ^ Trim an arity type so that it has at most the given arity. -- Any excess 'OneShotInfo's are truncated to 'topDiv', even if -- they end in 'ABot'. See Note [Arity trimming] trimArityType :: Int -> SafeArityType -> SafeArityType trimArityType Int max_arity at :: SafeArityType at@(AT [ATLamInfo] lams Divergence _) | [ATLamInfo] lams [ATLamInfo] -> Int -> Bool forall a. [a] -> Int -> Bool `lengthAtMost` Int max_arity = SafeArityType at | Bool otherwise = [ATLamInfo] -> Divergence -> SafeArityType AT (Int -> [ATLamInfo] -> [ATLamInfo] forall a. Int -> [a] -> [a] take Int max_arity [ATLamInfo] lams) Divergence topDiv data ArityOpts = ArityOpts { ArityOpts -> Bool ao_ped_bot :: !Bool -- See Note [Dealing with bottom] , ArityOpts -> Bool ao_dicts_cheap :: !Bool -- See Note [Eta expanding through dictionaries] } -- | The Arity returned is the number of value args the -- expression can be applied to without doing much work exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType -- exprEtaExpandArity is used when eta expanding -- e ==> \xy -> e x y -- Nothing if the expression has arity 0 exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType exprEtaExpandArity ArityOpts opts CoreExpr e | AT [] Divergence _ <- SafeArityType arity_type = Maybe SafeArityType forall a. Maybe a Nothing | Bool otherwise = SafeArityType -> Maybe SafeArityType forall a. a -> Maybe a Just SafeArityType arity_type where arity_type :: SafeArityType arity_type = SafeArityType -> SafeArityType safeArityType (HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType ArityEnv -> CoreExpr -> SafeArityType arityType (ArityOpts -> Bool -> ArityEnv findRhsArityEnv ArityOpts opts Bool False) CoreExpr e) {- ********************************************************************* * * findRhsArity * * ********************************************************************* -} findRhsArity :: ArityOpts -> RecFlag -> Id -> CoreExpr -> (Bool, SafeArityType) -- This implements the fixpoint loop for arity analysis -- See Note [Arity analysis] -- -- The Bool is True if the returned arity is greater than (exprArity rhs) -- so the caller should do eta-expansion -- That Bool is never True for join points, which are never eta-expanded -- -- Returns an SafeArityType that is guaranteed trimmed to typeArity of 'bndr' -- See Note [Arity trimming] findRhsArity :: ArityOpts -> RecFlag -> TyVar -> CoreExpr -> (Bool, SafeArityType) findRhsArity ArityOpts opts RecFlag is_rec TyVar bndr CoreExpr rhs | TyVar -> Bool isJoinId TyVar bndr = (Bool False, SafeArityType join_arity_type) -- False: see Note [Do not eta-expand join points] -- But do return the correct arity and bottom-ness, because -- these are used to set the bndr's IdInfo (#15517) -- Note [Invariants on join points] invariant 2b, in GHC.Core | Bool otherwise = (Bool arity_increased, SafeArityType non_join_arity_type) -- arity_increased: eta-expand if we'll get more lambdas -- to the top of the RHS where old_arity :: Int old_arity = CoreExpr -> Int exprArity CoreExpr rhs init_env :: ArityEnv init_env :: ArityEnv init_env = ArityOpts -> Bool -> ArityEnv findRhsArityEnv ArityOpts opts (TyVar -> Bool isJoinId TyVar bndr) -- Non-join-points only non_join_arity_type :: SafeArityType non_join_arity_type = case RecFlag is_rec of RecFlag Recursive -> Int -> SafeArityType -> SafeArityType go Int 0 SafeArityType botArityType RecFlag NonRecursive -> ArityEnv -> SafeArityType step ArityEnv init_env arity_increased :: Bool arity_increased = SafeArityType -> Int arityTypeArity SafeArityType non_join_arity_type Int -> Int -> Bool forall a. Ord a => a -> a -> Bool > Int old_arity -- Join-points only -- See Note [Arity for non-recursive join bindings] -- and Note [Arity for recursive join bindings] join_arity_type :: SafeArityType join_arity_type = case RecFlag is_rec of RecFlag Recursive -> Int -> SafeArityType -> SafeArityType go Int 0 SafeArityType botArityType RecFlag NonRecursive -> Int -> SafeArityType -> SafeArityType trimArityType Int ty_arity (HasDebugCallStack => CoreExpr -> SafeArityType CoreExpr -> SafeArityType cheapArityType CoreExpr rhs) ty_arity :: Int ty_arity = Type -> Int typeArity (TyVar -> Type idType TyVar bndr) use_call_cards :: [Card] use_call_cards = TyVar -> [Card] useSiteCallCards TyVar bndr step :: ArityEnv -> SafeArityType step :: ArityEnv -> SafeArityType step ArityEnv env = Int -> SafeArityType -> SafeArityType trimArityType Int ty_arity (SafeArityType -> SafeArityType) -> SafeArityType -> SafeArityType forall a b. (a -> b) -> a -> b $ SafeArityType -> SafeArityType safeArityType (SafeArityType -> SafeArityType) -> SafeArityType -> SafeArityType forall a b. (a -> b) -> a -> b $ -- See Note [Arity invariants for bindings], item (3) ArityEnv -> SafeArityType -> [Card] -> SafeArityType combineWithCallCards ArityEnv env (HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType ArityEnv -> CoreExpr -> SafeArityType arityType ArityEnv env CoreExpr rhs) [Card] use_call_cards -- trimArityType: see Note [Trim arity inside the loop] -- combineWithCallCards: take account of the demand on the -- binder. Perhaps it is always called with 2 args -- let f = \x. blah in (f 3 4, f 1 9) -- f's demand-info says how many args it is called with -- The fixpoint iteration (go), done for recursive bindings. We -- always do one step, but usually that produces a result equal -- to old_arity, and then we stop right away, because old_arity -- is assumed to be sound. In other words, arities should never -- decrease. Result: the common case is that there is just one -- iteration go :: Int -> SafeArityType -> SafeArityType go :: Int -> SafeArityType -> SafeArityType go !Int n cur_at :: SafeArityType cur_at@(AT [ATLamInfo] lams Divergence div) | Bool -> Bool not (Divergence -> Bool isDeadEndDiv Divergence div) -- the "stop right away" case , [ATLamInfo] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [ATLamInfo] lams Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int old_arity = SafeArityType cur_at -- from above | SafeArityType next_at SafeArityType -> SafeArityType -> Bool forall a. Eq a => a -> a -> Bool == SafeArityType cur_at = SafeArityType cur_at | Bool otherwise -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity] = Bool -> String -> SDoc -> SafeArityType -> SafeArityType forall a. HasCallStack => Bool -> String -> SDoc -> a -> a warnPprTrace (Bool debugIsOn Bool -> Bool -> Bool && Int n Int -> Int -> Bool forall a. Ord a => a -> a -> Bool > Int 2) String "Exciting arity" (Int -> SDoc -> SDoc nest Int 2 (TyVar -> SDoc forall a. Outputable a => a -> SDoc ppr TyVar bndr SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> SafeArityType -> SDoc forall a. Outputable a => a -> SDoc ppr SafeArityType cur_at SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> SafeArityType -> SDoc forall a. Outputable a => a -> SDoc ppr SafeArityType next_at SDoc -> SDoc -> SDoc forall doc. IsDoc doc => doc -> doc -> doc $$ CoreExpr -> SDoc forall a. Outputable a => a -> SDoc ppr CoreExpr rhs)) (SafeArityType -> SafeArityType) -> SafeArityType -> SafeArityType forall a b. (a -> b) -> a -> b $ Int -> SafeArityType -> SafeArityType go (Int nInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) SafeArityType next_at where next_at :: SafeArityType next_at = ArityEnv -> SafeArityType step (ArityEnv -> TyVar -> SafeArityType -> ArityEnv extendSigEnv ArityEnv init_env TyVar bndr SafeArityType cur_at) combineWithCallCards :: ArityEnv -> ArityType -> [Card] -> ArityType -- See Note [Combining arity type with demand info] combineWithCallCards :: ArityEnv -> SafeArityType -> [Card] -> SafeArityType combineWithCallCards ArityEnv env at :: SafeArityType at@(AT [ATLamInfo] lams Divergence div) [Card] cards | [ATLamInfo] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [ATLamInfo] lams = SafeArityType at | Bool otherwise = [ATLamInfo] -> Divergence -> SafeArityType AT ([ATLamInfo] -> [OneShotInfo] -> [ATLamInfo] zip_lams [ATLamInfo] lams [OneShotInfo] oss) Divergence div where oss :: [OneShotInfo] oss = (Card -> OneShotInfo) -> [Card] -> [OneShotInfo] forall a b. (a -> b) -> [a] -> [b] map Card -> OneShotInfo card_to_oneshot [Card] cards card_to_oneshot :: Card -> OneShotInfo card_to_oneshot Card n | Card -> Bool isAtMostOnce Card n, Bool -> Bool not (ArityEnv -> Bool pedanticBottoms ArityEnv env) -- Take care for -fpedantic-bottoms; -- see Note [Combining arity type with demand info], Wrinkle (CAD1) = OneShotInfo OneShotLam | Card n Card -> Card -> Bool forall a. Eq a => a -> a -> Bool == Card C_11 -- Safe to eta-expand even in the presence of -fpedantic-bottoms -- see Note [Combining arity type with demand info], Wrinkle (CAD1) = OneShotInfo OneShotLam | Bool otherwise = OneShotInfo NoOneShotInfo zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo] zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo] zip_lams [ATLamInfo] lams [] = [ATLamInfo] lams zip_lams [] [OneShotInfo] oss | Divergence -> Bool isDeadEndDiv Divergence div = [] | Bool otherwise = [ (Cost IsExpensive,OneShotInfo OneShotLam) | OneShotInfo _ <- (OneShotInfo -> Bool) -> [OneShotInfo] -> [OneShotInfo] forall a. (a -> Bool) -> [a] -> [a] takeWhile OneShotInfo -> Bool isOneShotInfo [OneShotInfo] oss] zip_lams ((Cost ch,OneShotInfo os1):[ATLamInfo] lams) (OneShotInfo os2:[OneShotInfo] oss) = (Cost ch, OneShotInfo os1 OneShotInfo -> OneShotInfo -> OneShotInfo `bestOneShot` OneShotInfo os2) ATLamInfo -> [ATLamInfo] -> [ATLamInfo] forall a. a -> [a] -> [a] : [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo] zip_lams [ATLamInfo] lams [OneShotInfo] oss useSiteCallCards :: Id -> [Card] useSiteCallCards :: TyVar -> [Card] useSiteCallCards TyVar bndr = [Card] call_arity_one_shots [Card] -> [Card] -> [Card] `zip_cards` [Card] dmd_one_shots where call_arity_one_shots :: [Card] call_arity_one_shots :: [Card] call_arity_one_shots | Int call_arity Int -> Int -> Bool forall a. Eq a => a -> a -> Bool == Int 0 = [] | Bool otherwise = Card C_0N Card -> [Card] -> [Card] forall a. a -> [a] -> [a] : Int -> Card -> [Card] forall a. Int -> a -> [a] replicate (Int call_arityInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) Card C_01 -- Call Arity analysis says /however often the function is called/, it is -- always applied to this many arguments. -- The first C_0N is because of the "however often it is called" part. -- Thus if Call Arity says "always applied to 3 args" then the one-shot info -- we get is [C_0N, C_01, C_01] call_arity :: Int call_arity = TyVar -> Int idCallArity TyVar bndr dmd_one_shots :: [Card] -- If the demand info is C(x,C(1,C(1,.))) then we know that an -- application to one arg is also an application to three dmd_one_shots :: [Card] dmd_one_shots = case TyVar -> Demand idDemandInfo TyVar bndr of Demand AbsDmd -> [] -- There is no use in eta expanding Demand BotDmd -> [] -- when the binding could be dropped instead Card _ :* SubDemand sd -> SubDemand -> [Card] callCards SubDemand sd -- Take the *longer* list zip_cards :: [Card] -> [Card] -> [Card] zip_cards (Card n1:[Card] ns1) (Card n2:[Card] ns2) = (Card n1 Card -> Card -> Card `glbCard` Card n2) Card -> [Card] -> [Card] forall a. a -> [a] -> [a] : [Card] -> [Card] -> [Card] zip_cards [Card] ns1 [Card] ns2 zip_cards [] [Card] ns2 = [Card] ns2 zip_cards [Card] ns1 [] = [Card] ns1 {- Note [Arity analysis] ~~~~~~~~~~~~~~~~~~~~~~~~ The motivating example for arity analysis is this: f = \x. let g = f (x+1) in \y. ...g... What arity does f have? Really it should have arity 2, but a naive look at the RHS won't see that. You need a fixpoint analysis which says it has arity "infinity" the first time round. This example happens a lot; it first showed up in Andy Gill's thesis, fifteen years ago! It also shows up in the code for 'rnf' on lists in #4138. We do the necessary, quite simple fixed-point iteration in 'findRhsArity', which assumes for a single binding 'ABot' on the first run and iterates until it finds a stable arity type. Two wrinkles * We often have to ask (see the Case or Let case of 'arityType') whether some expression is cheap. In the case of an application, that depends on the arity of the application head! That's why we have our own version of 'exprIsCheap', 'myExprIsCheap', that will integrate the optimistic arity types we have on f and g into the cheapness check. * Consider this (#18793) go = \ds. case ds of [] -> id (x:ys) -> let acc = go ys in case blah of True -> acc False -> \ x1 -> acc (negate x1) We must propagate go's optimistically large arity to @acc@, so that the tail call to @acc@ in the True branch has sufficient arity. This is done by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case of 'arityType'. Note [Exciting arity] ~~~~~~~~~~~~~~~~~~~~~ The fixed-point iteration in 'findRhsArity' stabilises very quickly in almost all cases. To get notified of cases where we need an usual number of iterations, we emit a warning in debug mode, so that we can investigate and make sure that we really can't do better. It's a gross hack, but catches real bugs (#18870). Now, which number is "unusual"? We pick n > 2. Here's a pretty common and expected example that takes two iterations and would ruin the specificity of the warning (from T18937): f :: [Int] -> Int -> Int f [] = id f (x:xs) = let y = sum [0..x] in \z -> f xs (y + z) Fixed-point iteration starts with arity type ⊥ for f. After the first iteration, we get arity type \??.T, e.g. arity 2, because we unconditionally 'floatIn' the let-binding (see its bottom case). After the second iteration, we get arity type \?.T, e.g. arity 1, because now we are no longer allowed to floatIn the non-cheap let-binding. Which is all perfectly benign, but means we do two iterations (well, actually 3 'step's to detect we are stable) and don't want to emit the warning. Note [Trim arity inside the loop] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here's an example (from gadt/nbe.hs) which caused trouble. data Exp g t where Lam :: Ty a -> Exp (g,a) b -> Exp g (a->b) eval :: Exp g t -> g -> t eval (Lam _ e) g = \a -> eval e (g,a) The danger is that we get arity 3 from analysing this; and the next time arity 4, and so on for ever. Solution: use trimArityType on each iteration. Note [Combining arity type with demand info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider let f = \x. let y = <expensive> in \p \q{os}. blah in ...(f a b)...(f c d)... * From the RHS we get an ArityType like AT [ (IsCheap,?), (IsExpensive,?), (IsCheap,OneShotLam) ] Dunno where "?" means NoOneShotInfo * From the body, the demand analyser (or Call Arity) will tell us that the function is always applied to at least two arguments. Combining these two pieces of info, we can get the final ArityType AT [ (IsCheap,?), (IsExpensive,OneShotLam), (IsCheap,OneShotLam) ] Dunno result: arity=3, which is better than we could do from either source alone. The "combining" part is done by combineWithCallCards. It uses info from both Call Arity and demand analysis. We may have /more/ call demands from the calls than we have lambdas in the binding. E.g. let f1 = \x. g x x in ...(f1 p q r)... -- Demand on f1 is C(x,C(1,C(1,L))) let f2 = \y. error y in ...(f2 p q r)... -- Demand on f2 is C(x,C(1,C(1,L))) In both these cases we can eta expand f1 and f2 to arity 3. But /only/ for called-once demands. Suppose we had let f1 = \y. g x x in ...let h = f1 p q in ...(h r1)...(h r2)... Now we don't want to eta-expand f1 to have 3 args; only two. Nor, in the case of f2, do we want to push that error call under a lambda. Hence the takeWhile in combineWithDemandDoneShots. Wrinkles: (CAD1) #24296 exposed a subtle interaction with -fpedantic-bottoms (See Note [Dealing with bottom]). Consider let f = \x y. error "blah" in f 2 1 `seq` Just (f 3 2 1) -- Demand on f is C(x,C(1,C(M,L))) Usually, it is OK to consider a lambda that is called *at most* once (so call cardinality C_01, abbreviated M) a one-shot lambda and eta-expand over it. But with -fpedantic-bottoms that is no longer true: If we were to eta-expand f to arity 3, we'd discard the error raised when evaluating `f 2 1`. Hence in the presence of -fpedantic-bottoms, we must have C_11 for eta-expansion. Note [Do not eta-expand join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Similarly to CPR (see Note [Don't w/w join points for CPR] in GHC.Core.Opt.WorkWrap), a join point stands well to gain from its outer binding's eta-expansion, and eta-expanding a join point is fraught with issues like how to deal with a cast: let join $j1 :: IO () $j1 = ... $j2 :: Int -> IO () $j2 n = if n > 0 then $j1 else ... => let join $j1 :: IO () $j1 = (\eta -> ...) `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) ~ IO () $j2 :: Int -> IO () $j2 n = (\eta -> if n > 0 then $j1 else ...) `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) ~ IO () The cast here can't be pushed inside the lambda (since it's not casting to a function type), so the lambda has to stay, but it can't because it contains a reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather than try and detect this situation (and whatever other situations crop up!), we don't bother; again, any surrounding eta-expansion will improve these join points anyway, since an outer cast can *always* be pushed inside. By the time CorePrep comes around, the code is very likely to look more like this: let join $j1 :: State# RealWorld -> (# State# RealWorld, ()) $j1 = (...) eta $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ()) $j2 = if n > 0 then $j1 else (...) eta Note [Arity for recursive join bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f x = joinrec j 0 = \ a b c -> (a,x,b) j n = j (n-1) in j 20 Obviously `f` should get arity 4. But it's a bit tricky: 1. Remember, we don't eta-expand join points; see Note [Do not eta-expand join points]. 2. But even though we aren't going to eta-expand it, we still want `j` to get idArity=4, via the findRhsArity fixpoint. Then when we are doing findRhsArity for `f`, we'll call arityType on f's RHS: - At the letrec-binding for `j` we'll whiz up an arity-4 ArityType for `j` (See Note [arityType for non-recursive let-bindings] in GHC.Core.Opt.Arity)b - At the occurrence (j 20) that arity-4 ArityType will leave an arity-3 result. 3. All this, even though j's /join-arity/ (stored in the JoinId) is 1. This is is the Main Reason that we want the idArity to sometimes be larger than the join-arity c.f. Note [Invariants on join points] item 2b in GHC.Core. 4. Be very careful of things like this (#21755): g x = let j 0 = \y -> (x,y) j n = expensive n `seq` j (n-1) in j x Here we do /not/ want eta-expand `g`, lest we duplicate all those (expensive n) calls. But it's fine: the findRhsArity fixpoint calculation will compute arity-1 for `j` (not arity 2); and that's just what we want. But we do need that fixpoint. Historical note: an earlier version of GHC did a hack in which we gave join points an ArityType of ABot, but that did not work with this #21755 case. 5. arityType does not usually expect to encounter free join points; see GHC.Core.Opt.Arity Note [No free join points in arityType]. But consider f x = join j1 y = .... in joinrec j2 z = ...j1 y... in j2 v When doing findRhsArity on `j2` we'll encounter the free `j1`. But that is fine, because we aren't going to eta-expand `j2`; we just want to know its arity. So we have a flag am_no_eta, switched on when doing findRhsArity on a join point RHS. If the flag is on, we allow free join points, but not otherwise. Note [Arity for non-recursive join bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note [Arity for recursive join bindings] deals with recursive join bindings. But what about /non-recursive/ones? If we just call findRhsArity, it will call arityType. And that can be expensive when we have deeply nested join points: join j1 x1 = join j2 x2 = join j3 x3 = blah3 in blah2 in blah1 (e.g. test T18698b). So we call cheapArityType instead. It's good enough for practical purposes. (Side note: maybe we should use cheapArity for the RHS of let bindings in the main arityType function.) -} {- ********************************************************************* * * arityType * * ********************************************************************* -} arityLam :: Id -> ArityType -> ArityType arityLam :: TyVar -> SafeArityType -> SafeArityType arityLam TyVar id (AT [ATLamInfo] oss Divergence div) = [ATLamInfo] -> Divergence -> SafeArityType AT ((Cost IsCheap, OneShotInfo one_shot) ATLamInfo -> [ATLamInfo] -> [ATLamInfo] forall a. a -> [a] -> [a] : [ATLamInfo] oss) Divergence div where one_shot :: OneShotInfo one_shot | Divergence -> Bool isDeadEndDiv Divergence div = OneShotInfo OneShotLam | Bool otherwise = TyVar -> OneShotInfo idStateHackOneShotInfo TyVar id -- If the body diverges, treat it as one-shot: no point -- in floating out, and no penalty for floating in -- See Wrinkle [Bottoming functions] in Note [ArityType] floatIn :: Cost -> ArityType -> ArityType -- We have something like (let x = E in b), -- where b has the given arity type. -- NB: be as lazy as possible in the Cost-of-E argument; -- we can often get away without ever looking at it -- See Note [Care with nested expressions] floatIn :: Cost -> SafeArityType -> SafeArityType floatIn Cost ch at :: SafeArityType at@(AT [ATLamInfo] lams Divergence div) = case [ATLamInfo] lams of [] -> SafeArityType at (Cost IsExpensive,OneShotInfo _):[ATLamInfo] _ -> SafeArityType at (Cost _,OneShotInfo os):[ATLamInfo] lams -> [ATLamInfo] -> Divergence -> SafeArityType AT ((Cost ch,OneShotInfo os)ATLamInfo -> [ATLamInfo] -> [ATLamInfo] forall a. a -> [a] -> [a] :[ATLamInfo] lams) Divergence div addWork :: ArityType -> ArityType -- Add work to the outermost level of the arity type addWork :: SafeArityType -> SafeArityType addWork at :: SafeArityType at@(AT [ATLamInfo] lams Divergence div) = case [ATLamInfo] lams of [] -> SafeArityType at ATLamInfo lam:[ATLamInfo] lams' -> [ATLamInfo] -> Divergence -> SafeArityType AT (ATLamInfo -> ATLamInfo add_work ATLamInfo lam ATLamInfo -> [ATLamInfo] -> [ATLamInfo] forall a. a -> [a] -> [a] : [ATLamInfo] lams') Divergence div add_work :: ATLamInfo -> ATLamInfo add_work :: ATLamInfo -> ATLamInfo add_work (Cost _,OneShotInfo os) = (Cost IsExpensive,OneShotInfo os) arityApp :: ArityType -> Cost -> ArityType -- Processing (fun arg) where at is the ArityType of fun, -- Knock off an argument and behave like 'let' arityApp :: SafeArityType -> Cost -> SafeArityType arityApp (AT ((Cost ch1,OneShotInfo _):[ATLamInfo] oss) Divergence div) Cost ch2 = Cost -> SafeArityType -> SafeArityType floatIn (Cost ch1 Cost -> Cost -> Cost `addCost` Cost ch2) ([ATLamInfo] -> Divergence -> SafeArityType AT [ATLamInfo] oss Divergence div) arityApp SafeArityType at Cost _ = SafeArityType at -- | Least upper bound in the 'ArityType' lattice. -- See the haddocks on 'ArityType' for the lattice. -- -- Used for branches of a @case@. andArityType :: ArityEnv -> ArityType -> ArityType -> ArityType andArityType :: ArityEnv -> SafeArityType -> SafeArityType -> SafeArityType andArityType ArityEnv env (AT (ATLamInfo lam1:[ATLamInfo] lams1) Divergence div1) (AT (ATLamInfo lam2:[ATLamInfo] lams2) Divergence div2) | AT [ATLamInfo] lams' Divergence div' <- ArityEnv -> SafeArityType -> SafeArityType -> SafeArityType andArityType ArityEnv env ([ATLamInfo] -> Divergence -> SafeArityType AT [ATLamInfo] lams1 Divergence div1) ([ATLamInfo] -> Divergence -> SafeArityType AT [ATLamInfo] lams2 Divergence div2) = [ATLamInfo] -> Divergence -> SafeArityType AT ((ATLamInfo lam1 ATLamInfo -> ATLamInfo -> ATLamInfo `and_lam` ATLamInfo lam2) ATLamInfo -> [ATLamInfo] -> [ATLamInfo] forall a. a -> [a] -> [a] : [ATLamInfo] lams') Divergence div' where (Cost ch1,OneShotInfo os1) and_lam :: ATLamInfo -> ATLamInfo -> ATLamInfo `and_lam` (Cost ch2,OneShotInfo os2) = ( Cost ch1 Cost -> Cost -> Cost `addCost` Cost ch2, OneShotInfo os1 OneShotInfo -> OneShotInfo -> OneShotInfo `bestOneShot` OneShotInfo os2) -- bestOneShot: see Note [Combining case branches: optimistic one-shot-ness] andArityType ArityEnv env (AT [] Divergence div1) SafeArityType at2 = ArityEnv -> Divergence -> SafeArityType -> SafeArityType andWithTail ArityEnv env Divergence div1 SafeArityType at2 andArityType ArityEnv env SafeArityType at1 (AT [] Divergence div2) = ArityEnv -> Divergence -> SafeArityType -> SafeArityType andWithTail ArityEnv env Divergence div2 SafeArityType at1 andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType andWithTail :: ArityEnv -> Divergence -> SafeArityType -> SafeArityType andWithTail ArityEnv env Divergence div1 at2 :: SafeArityType at2@(AT [ATLamInfo] lams2 Divergence _) | Divergence -> Bool isDeadEndDiv Divergence div1 -- case x of { T -> error; F -> \y.e } = SafeArityType at2 -- See Note | ArityEnv -> Bool pedanticBottoms ArityEnv env -- [Combining case branches: andWithTail] = [ATLamInfo] -> Divergence -> SafeArityType AT [] Divergence topDiv | Bool otherwise -- case x of { T -> plusInt <expensive>; F -> \y.e } = [ATLamInfo] -> Divergence -> SafeArityType AT ((ATLamInfo -> ATLamInfo) -> [ATLamInfo] -> [ATLamInfo] forall a b. (a -> b) -> [a] -> [b] map ATLamInfo -> ATLamInfo add_work [ATLamInfo] lams2) Divergence topDiv -- We know div1 = topDiv -- See Note [Combining case branches: andWithTail] {- Note [Combining case branches: optimistic one-shot-ness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When combining the ArityTypes for two case branches (with andArityType) and both ArityTypes have ATLamInfo, then we just combine their expensive-ness and one-shot info. The tricky point is when we have case x of True -> \x{one-shot). blah1 Fale -> \y. blah2 Since one-shot-ness is about the /consumer/ not the /producer/, we optimistically assume that if either branch is one-shot, we combine the best of the two branches, on the (slightly dodgy) basis that if we know one branch is one-shot, then they all must be. Surprisingly, this means that the one-shot arity type is effectively the top element of the lattice. Hence the call to `bestOneShot` in `andArityType`. Here's an example: go = \x. let z = go e0 go2 = \x. case x of True -> z False -> \s(one-shot). e1 in go2 x We *really* want to respect the one-shot annotation provided by the user and eta-expand go and go2. In the first fixpoint iteration of 'go' we'll bind 'go' to botArityType (written \.⊥, see Note [ArityType]). So 'z' will get arityType \.⊥; so we end up combining the True and False branches: \.⊥ `andArityType` \1.T That gives \1.T (see Note [Combining case branches: andWithTail], first bullet). So 'go2' gets an arityType of \(C?)(C1).T, which is what we want. Note [Care with nested expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider arityType (Just <big-expressions>) We will take arityType Just = AT [(IsCheap,os)] topDiv and then do arityApp (AT [(IsCheap os)] topDiv) (exprCost <big-expression>) The result will be AT [] topDiv. It doesn't matter what <big-expresison> is! The same is true of arityType (let x = <rhs> in <body>) where the cost of <rhs> doesn't matter unless <body> has a useful arityType. TL;DR in `floatIn`, do not to look at the Cost argument until you have to. I found this when looking at #24471, although I don't think it was really the main culprit. Note [Combining case branches: andWithTail] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When combining the ArityTypes for two case branches (with andArityType) and one side or the other has run out of ATLamInfo; then we get into `andWithTail`. * If one branch is guaranteed bottom (isDeadEndDiv), we just take the other. Consider case x of True -> \x. error "urk" False -> \xy. error "urk2" Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely diverge". So we need \??.⊥ for the whole thing, the /max/ of both arities. * Otherwise, if pedantic-bottoms is on, we just have to return AT [] topDiv. E.g. if we have f x z = case x of True -> \y. blah False -> z then we can't eta-expand, because that would change the behaviour of (f False bottom(). * But if pedantic-bottoms is not on, we allow ourselves to push `z` under a lambda (much as we allow ourselves to put the `case x` under a lambda). However we know nothing about the expensiveness or one-shot-ness of `z`, so we'd better assume it looks like (Expensive, NoOneShotInfo) all the way. Remembering Note [Combining case branches: optimistic one-shot-ness], we just add work to ever ATLamInfo, keeping the one-shot-ness. Note [Eta expanding through CallStacks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Just as it's good to eta-expand through dictionaries, so it is good to do so through CallStacks. #20103 is a case in point, where we got foo :: HasCallStack => Int -> Int foo = \(d::CallStack). let d2 = pushCallStack blah d in \(x:Int). blah We really want to eta-expand this! #20103 is quite convincing! We do this regardless of -fdicts-cheap; it's not really a dictionary. We also want to check both for (IP blah CallStack) and for CallStack itself. We might have either d :: IP blah CallStack -- Or HasCallStack d = (cs-expr :: CallStack) |> (nt-ax :: CallStack ~ IP blah CallStack) or just cs :: CallStack cs = cs-expr Test T20103 is an example of the latter. Note [Eta expanding through dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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. -} --------------------------- data ArityEnv = AE { ArityEnv -> ArityOpts am_opts :: !ArityOpts , ArityEnv -> IdEnv SafeArityType am_sigs :: !(IdEnv SafeArityType) -- NB `SafeArityType` so we can use this in myIsCheapApp -- See Note [Arity analysis] for details about fixed-point iteration. , ArityEnv -> Bool am_free_joins :: !Bool -- True <=> free join points allowed -- Used /only/ to support assertion checks } instance Outputable ArityEnv where ppr :: ArityEnv -> SDoc ppr (AE { am_sigs :: ArityEnv -> IdEnv SafeArityType am_sigs = IdEnv SafeArityType sigs, am_free_joins :: ArityEnv -> Bool am_free_joins = Bool free_joins }) = String -> SDoc forall doc. IsLine doc => String -> doc text String "AE" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> SDoc -> SDoc forall doc. IsLine doc => doc -> doc braces ([SDoc] -> SDoc forall doc. IsLine doc => [doc] -> doc sep [ String -> SDoc forall doc. IsLine doc => String -> doc text String "free joins:" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> Bool -> SDoc forall a. Outputable a => a -> SDoc ppr Bool free_joins , String -> SDoc forall doc. IsLine doc => String -> doc text String "sigs:" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> IdEnv SafeArityType -> SDoc forall a. Outputable a => a -> SDoc ppr IdEnv SafeArityType sigs ]) -- | The @ArityEnv@ used by 'findRhsArity'. findRhsArityEnv :: ArityOpts -> Bool -> ArityEnv findRhsArityEnv :: ArityOpts -> Bool -> ArityEnv findRhsArityEnv ArityOpts opts Bool free_joins = AE { am_opts :: ArityOpts am_opts = ArityOpts opts , am_free_joins :: Bool am_free_joins = Bool free_joins , am_sigs :: IdEnv SafeArityType am_sigs = IdEnv SafeArityType forall a. VarEnv a emptyVarEnv } freeJoinsOK :: ArityEnv -> Bool freeJoinsOK :: ArityEnv -> Bool freeJoinsOK (AE { am_free_joins :: ArityEnv -> Bool am_free_joins = Bool free_joins }) = Bool free_joins -- First some internal functions in snake_case for deleting in certain VarEnvs -- of the ArityType. Don't call these; call delInScope* instead! modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv modifySigEnv :: (IdEnv SafeArityType -> IdEnv SafeArityType) -> ArityEnv -> ArityEnv modifySigEnv IdEnv SafeArityType -> IdEnv SafeArityType f env :: ArityEnv env@(AE { am_sigs :: ArityEnv -> IdEnv SafeArityType am_sigs = IdEnv SafeArityType sigs }) = ArityEnv env { am_sigs = f sigs } {-# INLINE modifySigEnv #-} del_sig_env :: Id -> ArityEnv -> ArityEnv -- internal! del_sig_env :: TyVar -> ArityEnv -> ArityEnv del_sig_env TyVar id = (IdEnv SafeArityType -> IdEnv SafeArityType) -> ArityEnv -> ArityEnv modifySigEnv (\IdEnv SafeArityType sigs -> IdEnv SafeArityType -> TyVar -> IdEnv SafeArityType forall a. VarEnv a -> TyVar -> VarEnv a delVarEnv IdEnv SafeArityType sigs TyVar id) {-# INLINE del_sig_env #-} del_sig_env_list :: [Id] -> ArityEnv -> ArityEnv -- internal! del_sig_env_list :: [TyVar] -> ArityEnv -> ArityEnv del_sig_env_list [TyVar] ids = (IdEnv SafeArityType -> IdEnv SafeArityType) -> ArityEnv -> ArityEnv modifySigEnv (\IdEnv SafeArityType sigs -> IdEnv SafeArityType -> [TyVar] -> IdEnv SafeArityType forall a. VarEnv a -> [TyVar] -> VarEnv a delVarEnvList IdEnv SafeArityType sigs [TyVar] ids) {-# INLINE del_sig_env_list #-} -- end of internal deletion functions extendSigEnv :: ArityEnv -> Id -> SafeArityType -> ArityEnv extendSigEnv :: ArityEnv -> TyVar -> SafeArityType -> ArityEnv extendSigEnv ArityEnv env TyVar id SafeArityType ar_ty = (IdEnv SafeArityType -> IdEnv SafeArityType) -> ArityEnv -> ArityEnv modifySigEnv (\IdEnv SafeArityType sigs -> IdEnv SafeArityType -> TyVar -> SafeArityType -> IdEnv SafeArityType forall a. VarEnv a -> TyVar -> a -> VarEnv a extendVarEnv IdEnv SafeArityType sigs TyVar id SafeArityType ar_ty) (ArityEnv -> ArityEnv) -> ArityEnv -> ArityEnv forall a b. (a -> b) -> a -> b $ ArityEnv env delInScope :: ArityEnv -> Id -> ArityEnv delInScope :: ArityEnv -> TyVar -> ArityEnv delInScope ArityEnv env TyVar id = TyVar -> ArityEnv -> ArityEnv del_sig_env TyVar id ArityEnv env delInScopeList :: ArityEnv -> [Id] -> ArityEnv delInScopeList :: ArityEnv -> [TyVar] -> ArityEnv delInScopeList ArityEnv env [TyVar] ids = [TyVar] -> ArityEnv -> ArityEnv del_sig_env_list [TyVar] ids ArityEnv env lookupSigEnv :: ArityEnv -> Id -> Maybe SafeArityType lookupSigEnv :: ArityEnv -> TyVar -> Maybe SafeArityType lookupSigEnv (AE { am_sigs :: ArityEnv -> IdEnv SafeArityType am_sigs = IdEnv SafeArityType sigs }) TyVar id = IdEnv SafeArityType -> TyVar -> Maybe SafeArityType forall a. VarEnv a -> TyVar -> Maybe a lookupVarEnv IdEnv SafeArityType sigs TyVar id -- | Whether the analysis should be pedantic about bottoms. -- 'exprBotStrictness_maybe' always is. pedanticBottoms :: ArityEnv -> Bool pedanticBottoms :: ArityEnv -> Bool pedanticBottoms (AE { am_opts :: ArityEnv -> ArityOpts am_opts = ArityOpts{ ao_ped_bot :: ArityOpts -> Bool ao_ped_bot = Bool ped_bot }}) = Bool ped_bot exprCost :: ArityEnv -> CoreExpr -> Maybe Type -> Cost exprCost :: ArityEnv -> CoreExpr -> Maybe Type -> Cost exprCost ArityEnv env CoreExpr e Maybe Type mb_ty | ArityEnv -> CoreExpr -> Maybe Type -> Bool myExprIsCheap ArityEnv env CoreExpr e Maybe Type mb_ty = Cost IsCheap | Bool otherwise = Cost IsExpensive -- | A version of 'exprIsCheap' that considers results from arity analysis -- and optionally the expression's type. -- Under 'exprBotStrictness_maybe', no expressions are cheap. myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool myExprIsCheap (AE { am_opts :: ArityEnv -> ArityOpts am_opts = ArityOpts opts, am_sigs :: ArityEnv -> IdEnv SafeArityType am_sigs = IdEnv SafeArityType sigs }) CoreExpr e Maybe Type mb_ty = Bool cheap_dict Bool -> Bool -> Bool || CoreExpr -> Bool cheap_fun CoreExpr e where cheap_dict :: Bool cheap_dict = case Maybe Type mb_ty of Maybe Type Nothing -> Bool False Just Type ty -> (ArityOpts -> Bool ao_dicts_cheap ArityOpts opts Bool -> Bool -> Bool && Type -> Bool isDictTy Type ty) Bool -> Bool -> Bool || Type -> Bool isCallStackPredTy Type ty Bool -> Bool -> Bool || Type -> Bool isCallStackTy Type ty -- See Note [Eta expanding through dictionaries] -- See Note [Eta expanding through CallStacks] cheap_fun :: CoreExpr -> Bool cheap_fun CoreExpr e = CheapAppFun -> CoreExpr -> Bool exprIsCheapX (IdEnv SafeArityType -> CheapAppFun myIsCheapApp IdEnv SafeArityType sigs) CoreExpr e -- | A version of 'isCheapApp' that considers results from arity analysis. -- See Note [Arity analysis] for what's in the signature environment and why -- it's important. myIsCheapApp :: IdEnv SafeArityType -> CheapAppFun myIsCheapApp :: IdEnv SafeArityType -> CheapAppFun myIsCheapApp IdEnv SafeArityType sigs TyVar fn Int n_val_args = case IdEnv SafeArityType -> TyVar -> Maybe SafeArityType forall a. VarEnv a -> TyVar -> Maybe a lookupVarEnv IdEnv SafeArityType sigs TyVar fn of -- Nothing means not a local function, fall back to regular -- 'GHC.Core.Utils.isCheapApp' Maybe SafeArityType Nothing -> CheapAppFun isCheapApp TyVar fn Int n_val_args -- `Just at` means local function with `at` as current SafeArityType. -- NB the SafeArityType bit: that means we can ignore the cost flags -- in 'lams', and just consider the length -- Roughly approximate what 'isCheapApp' is doing. Just (AT [ATLamInfo] lams Divergence div) | Divergence -> Bool isDeadEndDiv Divergence div -> Bool True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils | Int n_val_args Int -> Int -> Bool forall a. Eq a => a -> a -> Bool == Int 0 -> Bool True -- Essentially | Int n_val_args Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < [ATLamInfo] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [ATLamInfo] lams -> Bool True -- isWorkFreeApp | Bool otherwise -> Bool False ---------------- arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> ArityType -- Precondition: all the free join points of the expression -- are bound by the ArityEnv -- See Note [No free join points in arityType] -- -- Returns ArityType, not SafeArityType. The caller must do -- trimArityType if necessary. arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType arityType ArityEnv env (Var TyVar v) | Just SafeArityType at <- ArityEnv -> TyVar -> Maybe SafeArityType lookupSigEnv ArityEnv env TyVar v -- Local binding = SafeArityType at | Bool otherwise = Bool -> SDoc -> SafeArityType -> SafeArityType forall a. HasCallStack => Bool -> SDoc -> a -> a assertPpr (ArityEnv -> Bool freeJoinsOK ArityEnv env Bool -> Bool -> Bool || Bool -> Bool not (TyVar -> Bool isJoinId TyVar v)) (TyVar -> SDoc forall a. Outputable a => a -> SDoc ppr TyVar v) (SafeArityType -> SafeArityType) -> SafeArityType -> SafeArityType forall a b. (a -> b) -> a -> b $ -- All join-point should be in the ae_sigs -- See Note [No free join points in arityType] TyVar -> SafeArityType idArityType TyVar v arityType ArityEnv env (Cast CoreExpr e Coercion _) = HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType ArityEnv -> CoreExpr -> SafeArityType arityType ArityEnv env CoreExpr e -- Lambdas; increase arity arityType ArityEnv env (Lam TyVar x CoreExpr e) | TyVar -> Bool isId TyVar x = TyVar -> SafeArityType -> SafeArityType arityLam TyVar x (HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType ArityEnv -> CoreExpr -> SafeArityType arityType ArityEnv env' CoreExpr e) | Bool otherwise = HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType ArityEnv -> CoreExpr -> SafeArityType arityType ArityEnv env' CoreExpr e where env' :: ArityEnv env' = ArityEnv -> TyVar -> ArityEnv delInScope ArityEnv env TyVar x -- Applications; decrease arity, except for types arityType ArityEnv env (App CoreExpr fun (Type Type _)) = HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType ArityEnv -> CoreExpr -> SafeArityType arityType ArityEnv env CoreExpr fun arityType ArityEnv env (App CoreExpr fun CoreExpr arg ) = SafeArityType -> Cost -> SafeArityType arityApp SafeArityType fun_at Cost arg_cost where fun_at :: SafeArityType fun_at = HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType ArityEnv -> CoreExpr -> SafeArityType arityType ArityEnv env CoreExpr fun arg_cost :: Cost arg_cost = ArityEnv -> CoreExpr -> Maybe Type -> Cost exprCost ArityEnv env CoreExpr arg Maybe Type forall a. Maybe a Nothing -- 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 ArityEnv env (Case CoreExpr scrut TyVar bndr Type _ [Alt TyVar] alts) | CoreExpr -> Bool exprIsDeadEnd CoreExpr scrut Bool -> Bool -> Bool || [Alt TyVar] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Alt TyVar] alts = SafeArityType botArityType -- Do not eta expand. See (1) in Note [Dealing with bottom] | Bool -> Bool not (ArityEnv -> Bool pedanticBottoms ArityEnv env) -- See (2) in Note [Dealing with bottom] , ArityEnv -> CoreExpr -> Maybe Type -> Bool myExprIsCheap ArityEnv env CoreExpr scrut (Type -> Maybe Type forall a. a -> Maybe a Just (TyVar -> Type idType TyVar bndr)) = SafeArityType alts_type | CoreExpr -> Bool exprOkForSpeculation CoreExpr scrut = SafeArityType alts_type | Bool otherwise -- In the remaining cases we may not push = SafeArityType -> SafeArityType addWork SafeArityType alts_type -- evaluation of the scrutinee in where env' :: ArityEnv env' = ArityEnv -> TyVar -> ArityEnv delInScope ArityEnv env TyVar bndr arity_type_alt :: Alt TyVar -> SafeArityType arity_type_alt (Alt AltCon _con [TyVar] bndrs CoreExpr rhs) = HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType ArityEnv -> CoreExpr -> SafeArityType arityType (ArityEnv -> [TyVar] -> ArityEnv delInScopeList ArityEnv env' [TyVar] bndrs) CoreExpr rhs alts_type :: SafeArityType alts_type = (SafeArityType -> SafeArityType -> SafeArityType) -> [SafeArityType] -> SafeArityType forall a. (a -> a -> a) -> [a] -> a forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a foldr1 (ArityEnv -> SafeArityType -> SafeArityType -> SafeArityType andArityType ArityEnv env) ((Alt TyVar -> SafeArityType) -> [Alt TyVar] -> [SafeArityType] forall a b. (a -> b) -> [a] -> [b] map Alt TyVar -> SafeArityType arity_type_alt [Alt TyVar] alts) arityType ArityEnv env (Let (NonRec TyVar b CoreExpr rhs) CoreExpr e) = -- See Note [arityType for non-recursive let-bindings] Cost -> SafeArityType -> SafeArityType floatIn Cost rhs_cost (HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType ArityEnv -> CoreExpr -> SafeArityType arityType ArityEnv env' CoreExpr e) where rhs_cost :: Cost rhs_cost = ArityEnv -> CoreExpr -> Maybe Type -> Cost exprCost ArityEnv env CoreExpr rhs (Type -> Maybe Type forall a. a -> Maybe a Just (TyVar -> Type idType TyVar b)) env' :: ArityEnv env' = ArityEnv -> TyVar -> SafeArityType -> ArityEnv extendSigEnv ArityEnv env TyVar b (SafeArityType -> SafeArityType safeArityType (HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType ArityEnv -> CoreExpr -> SafeArityType arityType ArityEnv env CoreExpr rhs)) arityType ArityEnv env (Let (Rec [(TyVar, CoreExpr)] prs) CoreExpr e) = -- See Note [arityType for recursive let-bindings] Cost -> SafeArityType -> SafeArityType floatIn (((TyVar, CoreExpr) -> Cost) -> [(TyVar, CoreExpr)] -> Cost forall a. (a -> Cost) -> [a] -> Cost allCosts (TyVar, CoreExpr) -> Cost bind_cost [(TyVar, CoreExpr)] prs) (HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType ArityEnv -> CoreExpr -> SafeArityType arityType ArityEnv env' CoreExpr e) where bind_cost :: (TyVar, CoreExpr) -> Cost bind_cost (TyVar b,CoreExpr e) = ArityEnv -> CoreExpr -> Maybe Type -> Cost exprCost ArityEnv env' CoreExpr e (Type -> Maybe Type forall a. a -> Maybe a Just (TyVar -> Type idType TyVar b)) env' :: ArityEnv env' = (ArityEnv -> (TyVar, CoreExpr) -> ArityEnv) -> ArityEnv -> [(TyVar, CoreExpr)] -> ArityEnv forall b a. (b -> a -> b) -> b -> [a] -> b forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl ArityEnv -> (TyVar, CoreExpr) -> ArityEnv extend_rec ArityEnv env [(TyVar, CoreExpr)] prs extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv extend_rec :: ArityEnv -> (TyVar, CoreExpr) -> ArityEnv extend_rec ArityEnv env (TyVar b,CoreExpr _) = ArityEnv -> TyVar -> SafeArityType -> ArityEnv extendSigEnv ArityEnv env TyVar b (SafeArityType -> ArityEnv) -> SafeArityType -> ArityEnv forall a b. (a -> b) -> a -> b $ TyVar -> SafeArityType idArityType TyVar b -- See Note [arityType for recursive let-bindings] arityType ArityEnv env (Tick CoreTickish t CoreExpr e) | Bool -> Bool not (CoreTickish -> Bool forall (pass :: TickishPass). GenTickish pass -> Bool tickishIsCode CoreTickish t) = HasDebugCallStack => ArityEnv -> CoreExpr -> SafeArityType ArityEnv -> CoreExpr -> SafeArityType arityType ArityEnv env CoreExpr e arityType ArityEnv _ CoreExpr _ = SafeArityType topArityType -------------------- idArityType :: Id -> ArityType idArityType :: TyVar -> SafeArityType idArityType TyVar v | DmdSig strict_sig <- TyVar -> DmdSig idDmdSig TyVar v , ([Demand] ds, Divergence div) <- DmdSig -> ([Demand], Divergence) splitDmdSig DmdSig strict_sig , Divergence -> Bool isDeadEndDiv Divergence div = [ATLamInfo] -> Divergence -> SafeArityType AT ([Demand] -> [ATLamInfo] -> [ATLamInfo] forall b a. [b] -> [a] -> [a] takeList [Demand] ds [ATLamInfo] one_shots) Divergence div | Type -> Bool isEmptyTy Type id_ty = SafeArityType botArityType | Bool otherwise = [ATLamInfo] -> Divergence -> SafeArityType AT (Int -> [ATLamInfo] -> [ATLamInfo] forall a. Int -> [a] -> [a] take (TyVar -> Int idArity TyVar v) [ATLamInfo] one_shots) Divergence topDiv where id_ty :: Type id_ty = TyVar -> Type idType TyVar v one_shots :: [(Cost,OneShotInfo)] -- One-shot-ness derived from the type one_shots :: [ATLamInfo] one_shots = Cost -> [Cost] forall a. a -> [a] repeat Cost IsCheap [Cost] -> [OneShotInfo] -> [ATLamInfo] forall a b. [a] -> [b] -> [(a, b)] `zip` Type -> [OneShotInfo] typeOneShots Type id_ty -------------------- cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType -- A fast and cheap version of arityType. -- Returns an ArityType with IsCheap everywhere -- c.f. GHC.Core.Utils.exprIsDeadEnd -- -- /Can/ encounter a free join-point Id; e.g. via the call -- in exprBotStrictness_maybe, which is called in lots -- of places -- -- Returns ArityType, not SafeArityType. The caller must do -- trimArityType if necessary. cheapArityType :: HasDebugCallStack => CoreExpr -> SafeArityType cheapArityType CoreExpr e = CoreExpr -> SafeArityType go CoreExpr e where go :: CoreExpr -> SafeArityType go (Var TyVar v) = TyVar -> SafeArityType idArityType TyVar v go (Cast CoreExpr e Coercion _) = CoreExpr -> SafeArityType go CoreExpr e go (Lam TyVar x CoreExpr e) | TyVar -> Bool isId TyVar x = TyVar -> SafeArityType -> SafeArityType arityLam TyVar x (CoreExpr -> SafeArityType go CoreExpr e) | Bool otherwise = CoreExpr -> SafeArityType go CoreExpr e go (App CoreExpr e CoreExpr a) | CoreExpr -> Bool forall b. Expr b -> Bool isTypeArg CoreExpr a = CoreExpr -> SafeArityType go CoreExpr e | Bool otherwise = CoreExpr -> SafeArityType -> SafeArityType arity_app CoreExpr a (CoreExpr -> SafeArityType go CoreExpr e) go (Tick CoreTickish t CoreExpr e) | Bool -> Bool not (CoreTickish -> Bool forall (pass :: TickishPass). GenTickish pass -> Bool tickishIsCode CoreTickish t) = CoreExpr -> SafeArityType go CoreExpr e -- Null alts: see Note [Empty case alternatives] in GHC.Core go (Case CoreExpr _ TyVar _ Type _ [Alt TyVar] alts) | [Alt TyVar] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Alt TyVar] alts = SafeArityType botArityType -- Give up on let, case. In particular, unlike arityType, -- we make no attempt to look inside let's. go CoreExpr _ = SafeArityType topArityType -- Specialised version of arityApp; all costs in ArityType are IsCheap -- See Note [exprArity for applications] -- NB: (1) coercions count as a value argument -- (2) we use the super-cheap exprIsTrivial rather than the -- more complicated and expensive exprIsCheap arity_app :: CoreExpr -> SafeArityType -> SafeArityType arity_app CoreExpr _ at :: SafeArityType at@(AT [] Divergence _) = SafeArityType at arity_app CoreExpr arg at :: SafeArityType at@(AT ((Cost cost,OneShotInfo _):[ATLamInfo] lams) Divergence div) | Bool -> SDoc -> Bool -> Bool forall a. HasCallStack => Bool -> SDoc -> a -> a assertPpr (Cost cost Cost -> Cost -> Bool forall a. Eq a => a -> a -> Bool == Cost IsCheap) (SafeArityType -> SDoc forall a. Outputable a => a -> SDoc ppr SafeArityType at SDoc -> SDoc -> SDoc forall doc. IsDoc doc => doc -> doc -> doc $$ CoreExpr -> SDoc forall a. Outputable a => a -> SDoc ppr CoreExpr arg) (Bool -> Bool) -> Bool -> Bool forall a b. (a -> b) -> a -> b $ Divergence -> Bool isDeadEndDiv Divergence div = [ATLamInfo] -> Divergence -> SafeArityType AT [ATLamInfo] lams Divergence div | CoreExpr -> Bool exprIsTrivial CoreExpr arg = [ATLamInfo] -> Divergence -> SafeArityType AT [ATLamInfo] lams Divergence topDiv | Bool otherwise = SafeArityType topArityType --------------- exprArity :: CoreExpr -> Arity -- ^ An approximate, even faster, version of 'cheapArityType' -- Roughly exprArity e = arityTypeArity (cheapArityType e) -- But it's a bit less clever about bottoms -- -- We do /not/ guarantee that exprArity e <= typeArity e -- You may need to do arity trimming after calling exprArity -- See Note [Arity trimming] -- Reason: if we do arity trimming here we have take exprType -- and that can be expensive if there is a large cast exprArity :: CoreExpr -> Int exprArity CoreExpr e = CoreExpr -> Int go CoreExpr e where go :: CoreExpr -> Int go (Var TyVar v) = TyVar -> Int idArity TyVar v go (Lam TyVar x CoreExpr e) | TyVar -> Bool isId TyVar x = CoreExpr -> Int go CoreExpr e Int -> Int -> Int forall a. Num a => a -> a -> a + Int 1 | Bool otherwise = CoreExpr -> Int go CoreExpr e go (Tick CoreTickish t CoreExpr e) | Bool -> Bool not (CoreTickish -> Bool forall (pass :: TickishPass). GenTickish pass -> Bool tickishIsCode CoreTickish t) = CoreExpr -> Int go CoreExpr e go (Cast CoreExpr e Coercion _) = CoreExpr -> Int go CoreExpr e go (App CoreExpr e (Type Type _)) = CoreExpr -> Int go CoreExpr e go (App CoreExpr f CoreExpr a) | CoreExpr -> Bool exprIsTrivial CoreExpr a = (CoreExpr -> Int go CoreExpr f Int -> Int -> Int forall a. Num a => a -> a -> a - Int 1) Int -> Int -> Int forall a. Ord a => a -> a -> a `max` Int 0 -- See Note [exprArity for applications] -- NB: coercions count as a value argument go CoreExpr _ = Int 0 --------------- exprIsDeadEnd :: CoreExpr -> Bool -- See Note [Bottoming expressions] -- This function is, in effect, just a specialised (and hence cheap) -- version of cheapArityType: -- exprIsDeadEnd e = case cheapArityType e of -- AT lams div -> null lams && isDeadEndDiv div -- See also exprBotStrictness_maybe, which uses cheapArityType exprIsDeadEnd :: CoreExpr -> Bool exprIsDeadEnd CoreExpr e = Int -> CoreExpr -> Bool go Int 0 CoreExpr e where go :: Arity -> CoreExpr -> Bool -- (go n e) = True <=> expr applied to n value args is bottom go :: Int -> CoreExpr -> Bool go Int _ (Lit {}) = Bool False go Int _ (Type {}) = Bool False go Int _ (Coercion {}) = Bool False go Int n (App CoreExpr e CoreExpr a) | CoreExpr -> Bool forall b. Expr b -> Bool isTypeArg CoreExpr a = Int -> CoreExpr -> Bool go Int n CoreExpr e | Bool otherwise = Int -> CoreExpr -> Bool go (Int nInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) CoreExpr e go Int n (Tick CoreTickish _ CoreExpr e) = Int -> CoreExpr -> Bool go Int n CoreExpr e go Int n (Cast CoreExpr e Coercion _) = Int -> CoreExpr -> Bool go Int n CoreExpr e go Int n (Let Bind TyVar _ CoreExpr e) = Int -> CoreExpr -> Bool go Int n CoreExpr e go Int n (Lam TyVar v CoreExpr e) | TyVar -> Bool isTyVar TyVar v = Int -> CoreExpr -> Bool go Int n CoreExpr e | Bool otherwise = Bool False go Int _ (Case CoreExpr _ TyVar _ Type _ [Alt TyVar] alts) = [Alt TyVar] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Alt TyVar] alts -- See Note [Empty case alternatives] in GHC.Core go Int n (Var TyVar v) | DmdSig -> Int -> Bool isDeadEndAppSig (TyVar -> DmdSig idDmdSig TyVar v) Int n = Bool True | Type -> Bool isEmptyTy (TyVar -> Type idType TyVar v) = Bool True | Bool otherwise = Bool False {- Note [Bottoming expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A bottoming expression is guaranteed to diverge, or raise an exception. We can test for it in two different ways, and exprIsDeadEnd checks for both of these situations: * Visibly-bottom computations. For example (error Int "Hello") is visibly bottom. The strictness analyser also finds out if a function diverges or raises an exception, and puts that info in its strictness signature. * Empty types. If a type is empty, its only inhabitant is bottom. For example: data T f :: T -> Bool f = \(x:t). case x of Bool {} Since T has no data constructors, the case alternatives are of course empty. However note that 'x' is not bound to a visibly-bottom value; it's the *type* that tells us it's going to diverge. A GADT may also be empty even though it has constructors: data T a where T1 :: a -> T Bool T2 :: T Int ...(case (x::T Char) of {})... Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), which is likewise uninhabited. Note [No free join points in arityType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we call arityType on this expression (EX1) \x . case x of True -> \y. e False -> $j 3 where $j is a join point. It really makes no sense to talk of the arity of this expression, because it has a free join point. In particular, we can't eta-expand the expression because we'd have do the same thing to the binding of $j, and we can't see that binding. If we had (EX2) \x. join $j y = blah case x of True -> \y. e False -> $j 3 then it would make perfect sense: we can determine $j's ArityType, and propagate it to the usage site as usual. But how can we get (EX1)? It doesn't make much sense, because $j can't be a join point under the \x anyway. So we make it a precondition of arityType that the argument has no free join-point Ids. (This is checked with an assert in the Var case of arityType.) Wrinkles * We /do/ allow free join point when doing findRhsArity for join-point right-hand sides. See Note [Arity for recursive join bindings] point (5) in GHC.Core.Opt.Simplify.Utils. * The invariant (no free join point in arityType) risks being invalidated by one very narrow special case: runRW# join $j y = blah runRW# (\s. case x of True -> \y. e False -> $j x) We have special magic in OccurAnal, and Simplify to allow continuations to move into the body of a runRW# call. So we are careful never to attempt to eta-expand the (\s.blah) in the argument to runRW#, at least not when there is a literal lambda there, so that OccurAnal has seen it and allowed join points bound outside. See Note [No eta-expansion in runRW#] in GHC.Core.Opt.Simplify.Iteration. Note [arityType for non-recursive let-bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For non-recursive let-bindings, we just get the arityType of the RHS, and extend the environment. That works nicely for things like this (#18793): go = \ ds. case ds_a2CF of { [] -> id : y ys -> case y of { GHC.Types.I# x -> let acc = go ys in case x ># 42# of { __DEFAULT -> acc 1# -> \x1. acc (negate x2) Here we want to get a good arity for `acc`, based on the ArityType of `go`. All this is particularly important for join points. Consider this (#18328) f x = join j y = case y of True -> \a. blah False -> \b. blah in case x of A -> j True B -> \c. blah C -> j False and suppose the join point is too big to inline. Now, what is the arity of f? If we inlined the join point, we'd definitely say "arity 2" because we are prepared to push case-scrutinisation inside a lambda. It's important that we extend the envt with j's ArityType, so that we can use that information in the A/C branch of the case. Note [arityType for recursive let-bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For /recursive/ bindings it's more difficult, to call arityType (as we do in Note [arityType for non-recursive let-bindings]) because we don't have an ArityType to put in the envt for the recursively bound Ids. So for we satisfy ourselves with whizzing up up an ArityType from the idArity of the function, via idArityType. That is nearly equivalent to deleting the binder from the envt, at which point we'll call idArityType at the occurrences. But doing it here means (a) we only call idArityType once, no matter how many occurrences, and (b) we can check (in the arityType (Var v) case) that we don't mention free join-point Ids. See Note [No free join points in arityType]. But see Note [Arity for recursive join bindings] in GHC.Core.Opt.Simplify.Utils for dark corners. -} {- %************************************************************************ %* * The main eta-expander %* * %************************************************************************ We go for: f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym (n >= 0) where (in both cases) * The xi can include type variables * The yi are all value variables * N is a NORMAL FORM (i.e. no redexes anywhere) wanting a suitable number of extra args. The biggest reason for doing this is for cases like f = \x -> case x of True -> \y -> e1 False -> \y -> e2 Here we want to get the lambdas together. A good example is the nofib program fibheaps, which gets 25% more allocation if you don't do this eta-expansion. We may have to sandwich some coerces between the lambdas to make the types work. exprEtaExpandArity looks through coerces when computing arity; and etaExpand adds the coerces as necessary when actually computing the expansion. Note [No crap in eta-expanded code] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The eta expander is careful not to introduce "crap". In particular, given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it returns a CoreExpr satisfying the same invariant. See Note [Eta expansion and the CorePrep invariants] in CorePrep. This means the eta-expander has to do a bit of on-the-fly simplification but it's not too hard. The alternative, of relying on a subsequent clean-up phase of the Simplifier to de-crapify the result, means you can't really use it in CorePrep, which is painful. Note [Eta expansion for join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The no-crap rule is very tiresome to guarantee when we have join points. Consider eta-expanding let j :: Int -> Int -> Bool j x = e in b The simple way is \(y::Int). (let j x = e in b) y The no-crap way is \(y::Int). let j' :: Int -> Bool j' x = e y in b[j'/j] y where I have written b[j'/j] to stress that j's type has changed. Note that (of course!) we have to push the application inside the RHS of the join as well as into the body. AND if j has an unfolding we have to push it into there too. AND j might be recursive... So for now I'm abandoning the no-crap rule in this case, conscious that this causes the ugly Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]. (Moreover, I think that casts can make the no-crap rule fail too.) Note [Eta expansion and SCCs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that SCCs are not treated specially by etaExpand. 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" Note [Eta expansion and source notes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ CorePrep puts floatable ticks outside of value applications, but not type applications. As a result we might be trying to eta-expand an expression like (src<...> v) @a which we want to lead to code like \x -> src<...> v @a x This means that we need to look through type applications and be ready to re-add floats on the top. Note [Eta expansion with ArityType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The etaExpandAT function takes an ArityType (not just an Arity) to guide eta-expansion. Why? Because we want to preserve one-shot info. Consider foo = \x. case x of True -> (\s{os}. blah) |> co False -> wubble We'll get an ArityType for foo of \?1.T. Then we want to eta-expand to foo = (\x. \eta{os}. (case x of ...as before...) eta) |> some_co That 'eta' binder is fresh, and we really want it to have the one-shot flag from the inner \s{os}. By expanding with the ArityType gotten from analysing the RHS, we achieve this neatly. This makes a big difference to the one-shot monad trick; see Note [The one-shot state monad trick] in GHC.Utils.Monad. -} -- | @etaExpand n e@ returns an expression with -- the same meaning as @e@, but with arity @n@. -- -- Given: -- -- > e' = etaExpand n e -- -- We should have that: -- -- > ty = exprType e = exprType e' etaExpand :: Arity -> CoreExpr -> CoreExpr etaExpand :: Int -> CoreExpr -> CoreExpr etaExpand Int n CoreExpr orig_expr = InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr eta_expand InScopeSet in_scope (Int -> OneShotInfo -> [OneShotInfo] forall a. Int -> a -> [a] replicate Int n OneShotInfo NoOneShotInfo) CoreExpr orig_expr where in_scope :: InScopeSet in_scope = {-#SCC "eta_expand:in-scopeX" #-} VarSet -> InScopeSet mkInScopeSet (CoreExpr -> VarSet exprFreeVars CoreExpr orig_expr) etaExpandAT :: InScopeSet -> SafeArityType -> CoreExpr -> CoreExpr -- See Note [Eta expansion with ArityType] -- -- We pass in the InScopeSet from the simplifier to avoid recomputing -- it here, which can be jolly expensive if the casts are big -- In #18223 it took 10% of compile time just to do the exprFreeVars! etaExpandAT :: InScopeSet -> SafeArityType -> CoreExpr -> CoreExpr etaExpandAT InScopeSet in_scope SafeArityType at CoreExpr orig_expr = InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr eta_expand InScopeSet in_scope (SafeArityType -> [OneShotInfo] arityTypeOneShots SafeArityType at) CoreExpr orig_expr -- etaExpand arity e = res -- Then 'res' has at least 'arity' lambdas at the top -- possibly with a cast wrapped around the outside -- See Note [Eta expansion with ArityType] -- -- etaExpand deals with for-alls. For example: -- etaExpand 1 E -- where E :: forall a. a -> a -- would return -- (/\b. \y::a -> E b y) eta_expand :: InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr eta_expand :: InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr eta_expand InScopeSet in_scope [OneShotInfo] one_shots (Cast CoreExpr expr Coercion co) = HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr CoreExpr -> Coercion -> CoreExpr mkCast (InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr eta_expand InScopeSet in_scope [OneShotInfo] one_shots CoreExpr expr) Coercion co -- This mkCast is important, because eta_expand might return an -- expression with a cast at the outside; and tryCastWorkerWrapper -- asssumes that we don't have nested casts. Makes a difference -- in compile-time for T18223 eta_expand InScopeSet in_scope [OneShotInfo] one_shots CoreExpr orig_expr = InScopeSet -> [OneShotInfo] -> [TyVar] -> CoreExpr -> CoreExpr go InScopeSet in_scope [OneShotInfo] one_shots [] CoreExpr orig_expr where -- Strip off existing lambdas and casts before handing off to mkEtaWW -- This is mainly to avoid spending time cloning binders and substituting -- when there is actually nothing to do. It's slightly awkward to deal -- with casts here, apart from the topmost one, and they are rare, so -- if we find one we just hand off to mkEtaWW anyway -- Note [Eta expansion and SCCs] go :: InScopeSet -> [OneShotInfo] -> [TyVar] -> CoreExpr -> CoreExpr go InScopeSet _ [] [TyVar] _ CoreExpr _ = CoreExpr orig_expr -- Already has the specified arity; no-op go InScopeSet in_scope oss :: [OneShotInfo] oss@(OneShotInfo _:[OneShotInfo] oss1) [TyVar] vs (Lam TyVar v CoreExpr body) | TyVar -> Bool isTyVar TyVar v = InScopeSet -> [OneShotInfo] -> [TyVar] -> CoreExpr -> CoreExpr go (InScopeSet in_scope InScopeSet -> TyVar -> InScopeSet `extendInScopeSet` TyVar v) [OneShotInfo] oss (TyVar vTyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] :[TyVar] vs) CoreExpr body | Bool otherwise = InScopeSet -> [OneShotInfo] -> [TyVar] -> CoreExpr -> CoreExpr go (InScopeSet in_scope InScopeSet -> TyVar -> InScopeSet `extendInScopeSet` TyVar v) [OneShotInfo] oss1 (TyVar vTyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] :[TyVar] vs) CoreExpr body go InScopeSet in_scope [OneShotInfo] oss [TyVar] rev_vs CoreExpr expr = -- pprTrace "ee" (vcat [ppr in_scope', ppr top_bndrs, ppr eis]) $ CoreExpr -> CoreExpr retick (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr forall a b. (a -> b) -> a -> b $ EtaInfo -> CoreExpr -> CoreExpr etaInfoAbs EtaInfo top_eis (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr forall a b. (a -> b) -> a -> b $ InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr etaInfoApp InScopeSet in_scope' CoreExpr sexpr EtaInfo eis where (InScopeSet in_scope', eis :: EtaInfo eis@(EI [TyVar] eta_bndrs MCoercionR mco)) = [OneShotInfo] -> SDoc -> InScopeSet -> Type -> (InScopeSet, EtaInfo) mkEtaWW [OneShotInfo] oss (CoreExpr -> SDoc forall a. Outputable a => a -> SDoc ppr CoreExpr orig_expr) InScopeSet in_scope (HasDebugCallStack => CoreExpr -> Type CoreExpr -> Type exprType CoreExpr expr) top_bndrs :: [TyVar] top_bndrs = [TyVar] -> [TyVar] forall a. [a] -> [a] reverse [TyVar] rev_vs top_eis :: EtaInfo top_eis = [TyVar] -> MCoercionR -> EtaInfo EI ([TyVar] top_bndrs [TyVar] -> [TyVar] -> [TyVar] forall a. [a] -> [a] -> [a] ++ [TyVar] eta_bndrs) ([TyVar] -> MCoercionR -> MCoercionR mkPiMCos [TyVar] top_bndrs MCoercionR mco) -- Find ticks behind type apps. -- See Note [Eta expansion and source notes] -- I don't really understand this code SLPJ May 21 (CoreExpr expr', [CoreExpr] args) = CoreExpr -> (CoreExpr, [CoreExpr]) forall b. Expr b -> (Expr b, [Expr b]) collectArgs CoreExpr expr ([CoreTickish] ticks, CoreExpr expr'') = (CoreTickish -> Bool) -> CoreExpr -> ([CoreTickish], CoreExpr) forall b. (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b) stripTicksTop CoreTickish -> Bool forall (pass :: TickishPass). GenTickish pass -> Bool tickishFloatable CoreExpr expr' sexpr :: CoreExpr sexpr = CoreExpr -> [CoreExpr] -> CoreExpr forall b. Expr b -> [Expr b] -> Expr b mkApps CoreExpr expr'' [CoreExpr] args retick :: CoreExpr -> CoreExpr retick CoreExpr expr = (CoreTickish -> CoreExpr -> CoreExpr) -> CoreExpr -> [CoreTickish] -> CoreExpr forall a b. (a -> b -> b) -> b -> [a] -> b forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr CoreTickish -> CoreExpr -> CoreExpr mkTick CoreExpr expr [CoreTickish] ticks {- ********************************************************************* * * The EtaInfo mechanism mkEtaWW, etaInfoAbs, etaInfoApp * * ********************************************************************* -} {- Note [The EtaInfo mechanism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have (e :: ty) and we want to eta-expand it to arity N. This what eta_expand does. We do it in two steps: 1. mkEtaWW: from 'ty' and 'N' build a EtaInfo which describes the shape of the expansion necessary to expand to arity N. 2. Build the term \ v1..vn. e v1 .. vn where those abstractions and applications are described by the same EtaInfo. Specifically we build the term etaInfoAbs etas (etaInfoApp in_scope e etas) where etas :: EtaInfo etaInfoAbs builds the lambdas etaInfoApp builds the applications Note that the /same/ EtaInfo drives both etaInfoAbs and etaInfoApp To a first approximation EtaInfo is just [Var]. But casts complicate the question. If we have newtype N a = MkN (S -> a) axN :: N a ~ S -> a and e :: N (N Int) then the eta-expansion should look like (\(x::S) (y::S) -> (e |> co) x y) |> sym co where co :: N (N Int) ~ S -> S -> Int co = axN @(N Int) ; (S -> axN @Int) We want to get one cast, at the top, to account for all those nested newtypes. This is expressed by the EtaInfo type: data EtaInfo = EI [Var] MCoercionR Precisely, here is the (EtaInfo Invariant): EI bs co :: EtaInfo describes a particular eta-expansion, thus: Abstraction: (\b1 b2 .. bn. []) |> sym co Application: ([] |> co) b1 b2 .. bn e :: T co :: T ~R (t1 -> t2 -> .. -> tn -> tr) e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co Note [Check for reflexive casts in eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It turns out that the casts created by the above mechanism are often Refl. When casts are very deeply nested (as happens in #18223), the repetition of types can make the overall term very large. So there is a big payoff in cancelling out casts aggressively wherever possible. (See also Note [No crap in eta-expanded code].) This matters particularly in etaInfoApp, where we * Do beta-reduction on the fly * Use getArg_maybe to get a cast out of the way, so that we can do beta reduction Together this makes a big difference. Consider when e is case x of True -> (\x -> e1) |> c1 False -> (\p -> e2) |> c2 When we eta-expand this to arity 1, say, etaInfoAbs will wrap a (\eta) around the outside and use etaInfoApp to apply each alternative to 'eta'. We want to beta-reduce all that junk away. #18223 was a dramatic example in which the intermediate term was grotesquely huge, even though the next Simplifier iteration squashed it. Better to kill it at birth. The crucial spots in etaInfoApp are: * `checkReflexiveMCo` in the (Cast e co) case of `go` * `checkReflexiveMCo` in `pushCoArg` * Less important: checkReflexiveMCo in the final case of `go` Collectively these make a factor-of-5 difference to the total allocation of T18223, so take care if you change this stuff! Example: newtype N = MkN (Y->Z) f :: X -> N f = \(x::X). ((\(y::Y). blah) |> fco) where fco :: (Y->Z) ~ N mkEtaWW makes an EtaInfo of (EI [(eta1:X), (eta2:Y)] eta_co where eta_co :: (X->N) ~ (X->Y->Z) eta_co = (<X> -> nco) nco :: N ~ (Y->Z) -- Comes from topNormaliseNewType_maybe Now, when we push that eta_co inward in etaInfoApp: * In the (Cast e co) case, the 'fco' and 'nco' will meet, and should cancel. * When we meet the (\y.e) we want no cast on the y. -} -------------- data EtaInfo = EI [Var] MCoercionR -- See Note [The EtaInfo mechanism] instance Outputable EtaInfo where ppr :: EtaInfo -> SDoc ppr (EI [TyVar] vs MCoercionR mco) = String -> SDoc forall doc. IsLine doc => String -> doc text String "EI" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> [TyVar] -> SDoc forall a. Outputable a => a -> SDoc ppr [TyVar] vs SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> SDoc -> SDoc forall doc. IsLine doc => doc -> doc parens (MCoercionR -> SDoc forall a. Outputable a => a -> SDoc ppr MCoercionR mco) etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr -- (etaInfoApp s e (EI bs mco) returns something equivalent to -- ((substExpr s e) |> mco b1 .. bn) -- See Note [The EtaInfo mechanism] -- -- NB: With very deeply nested casts, this function can be expensive -- In T18223, this function alone costs 15% of allocation, all -- spent in the calls to substExprSC and substBindSC etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr etaInfoApp InScopeSet in_scope CoreExpr expr EtaInfo eis = Subst -> CoreExpr -> EtaInfo -> CoreExpr go (InScopeSet -> Subst mkEmptySubst InScopeSet in_scope) CoreExpr expr EtaInfo eis where go :: Subst -> CoreExpr -> EtaInfo -> CoreExpr -- 'go' pushed down the eta-infos into the branch of a case -- and the body of a let; and does beta-reduction if possible -- go subst fun co [b1,..,bn] returns (subst(fun) |> co) b1 .. bn go :: Subst -> CoreExpr -> EtaInfo -> CoreExpr go Subst subst (Tick CoreTickish t CoreExpr e) EtaInfo eis = CoreTickish -> CoreExpr -> CoreExpr forall b. CoreTickish -> Expr b -> Expr b Tick (Subst -> CoreTickish -> CoreTickish substTickish Subst subst CoreTickish t) (Subst -> CoreExpr -> EtaInfo -> CoreExpr go Subst subst CoreExpr e EtaInfo eis) go Subst subst (Cast CoreExpr e Coercion co) (EI [TyVar] bs MCoercionR mco) = Subst -> CoreExpr -> EtaInfo -> CoreExpr go Subst subst CoreExpr e ([TyVar] -> MCoercionR -> EtaInfo EI [TyVar] bs MCoercionR mco') where mco' :: MCoercionR mco' = MCoercionR -> MCoercionR checkReflexiveMCo (HasDebugCallStack => Subst -> Coercion -> Coercion Subst -> Coercion -> Coercion Core.substCo Subst subst Coercion co Coercion -> MCoercionR -> MCoercionR `mkTransMCoR` MCoercionR mco) -- See Note [Check for reflexive casts in eta expansion] go Subst subst (Case CoreExpr e TyVar b Type ty [Alt TyVar] alts) EtaInfo eis = CoreExpr -> TyVar -> Type -> [Alt TyVar] -> CoreExpr forall b. Expr b -> b -> Type -> [Alt b] -> Expr b Case (HasDebugCallStack => Subst -> CoreExpr -> CoreExpr Subst -> CoreExpr -> CoreExpr Core.substExprSC Subst subst CoreExpr e) TyVar b1 Type ty' [Alt TyVar] alts' where (Subst subst1, TyVar b1) = Subst -> TyVar -> (Subst, TyVar) Core.substBndr Subst subst TyVar b alts' :: [Alt TyVar] alts' = (Alt TyVar -> Alt TyVar) -> [Alt TyVar] -> [Alt TyVar] forall a b. (a -> b) -> [a] -> [b] map Alt TyVar -> Alt TyVar subst_alt [Alt TyVar] alts ty' :: Type ty' = Type -> EtaInfo -> Type etaInfoAppTy (Subst -> Type -> Type substTyUnchecked Subst subst Type ty) EtaInfo eis subst_alt :: Alt TyVar -> Alt TyVar subst_alt (Alt AltCon con [TyVar] bs CoreExpr rhs) = AltCon -> [TyVar] -> CoreExpr -> Alt TyVar forall b. AltCon -> [b] -> Expr b -> Alt b Alt AltCon con [TyVar] bs' (Subst -> CoreExpr -> EtaInfo -> CoreExpr go Subst subst2 CoreExpr rhs EtaInfo eis) where (Subst subst2,[TyVar] bs') = Subst -> [TyVar] -> (Subst, [TyVar]) forall (f :: * -> *). Traversable f => Subst -> f TyVar -> (Subst, f TyVar) Core.substBndrs Subst subst1 [TyVar] bs go Subst subst (Let Bind TyVar b CoreExpr e) EtaInfo eis | Bool -> Bool not (Bind TyVar -> Bool isJoinBind Bind TyVar b) -- See Note [Eta expansion for join points] = Bind TyVar -> CoreExpr -> CoreExpr forall b. Bind b -> Expr b -> Expr b Let Bind TyVar b' (Subst -> CoreExpr -> EtaInfo -> CoreExpr go Subst subst' CoreExpr e EtaInfo eis) where (Subst subst', Bind TyVar b') = HasDebugCallStack => Subst -> Bind TyVar -> (Subst, Bind TyVar) Subst -> Bind TyVar -> (Subst, Bind TyVar) Core.substBindSC Subst subst Bind TyVar b -- Beta-reduction if possible, pushing any intervening casts past -- the argument. See Note [The EtaInfo mechanism] go Subst subst (Lam TyVar v CoreExpr e) (EI (TyVar b:[TyVar] bs) MCoercionR mco) | Just (CoreExpr arg,MCoercionR mco') <- MCoercionR -> CoreExpr -> Maybe (CoreExpr, MCoercionR) pushMCoArg MCoercionR mco (TyVar -> CoreExpr forall b. TyVar -> Expr b varToCoreExpr TyVar b) = Subst -> CoreExpr -> EtaInfo -> CoreExpr go (Subst -> TyVar -> CoreExpr -> Subst Core.extendSubst Subst subst TyVar v CoreExpr arg) CoreExpr e ([TyVar] -> MCoercionR -> EtaInfo EI [TyVar] bs MCoercionR mco') -- Stop pushing down; just wrap the expression up -- See Note [Check for reflexive casts in eta expansion] go Subst subst CoreExpr e (EI [TyVar] bs MCoercionR mco) = HasDebugCallStack => Subst -> CoreExpr -> CoreExpr Subst -> CoreExpr -> CoreExpr Core.substExprSC Subst subst CoreExpr e CoreExpr -> MCoercionR -> CoreExpr `mkCastMCo` MCoercionR -> MCoercionR checkReflexiveMCo MCoercionR mco CoreExpr -> [TyVar] -> CoreExpr forall b. Expr b -> [TyVar] -> Expr b `mkVarApps` [TyVar] bs -------------- etaInfoAppTy :: Type -> EtaInfo -> Type -- If e :: ty -- then etaInfoApp e eis :: etaInfoApp ty eis etaInfoAppTy :: Type -> EtaInfo -> Type etaInfoAppTy Type ty (EI [TyVar] bs MCoercionR mco) = HasDebugCallStack => SDoc -> Type -> [CoreExpr] -> Type SDoc -> Type -> [CoreExpr] -> Type applyTypeToArgs (String -> SDoc forall doc. IsLine doc => String -> doc text String "etaInfoAppTy") Type ty1 ((TyVar -> CoreExpr) -> [TyVar] -> [CoreExpr] forall a b. (a -> b) -> [a] -> [b] map TyVar -> CoreExpr forall b. TyVar -> Expr b varToCoreExpr [TyVar] bs) where ty1 :: Type ty1 = case MCoercionR mco of MCoercionR MRefl -> Type ty MCo Coercion co -> Coercion -> Type coercionRKind Coercion co -------------- etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr -- See Note [The EtaInfo mechanism] etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr etaInfoAbs (EI [TyVar] bs MCoercionR mco) CoreExpr expr = ([TyVar] -> CoreExpr -> CoreExpr forall b. [b] -> Expr b -> Expr b mkLams [TyVar] bs CoreExpr expr) CoreExpr -> MCoercionR -> CoreExpr `mkCastMCo` MCoercionR -> MCoercionR mkSymMCo MCoercionR mco -------------- -- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding -- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the -- free variables of @e@. -- -- Note that this function is entirely unconcerned about cost centres and other -- semantically-irrelevant source annotations, so call sites must take care to -- preserve that info. See Note [Eta expansion and SCCs]. mkEtaWW :: [OneShotInfo] -- ^ How many value arguments to eta-expand -> SDoc -- ^ The pretty-printed original expression, for warnings. -> InScopeSet -- ^ A super-set of the free vars of the expression to eta-expand. -> Type -> (InScopeSet, EtaInfo) -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'. -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the -- fresh variables in 'EtaInfo'. mkEtaWW :: [OneShotInfo] -> SDoc -> InScopeSet -> Type -> (InScopeSet, EtaInfo) mkEtaWW [OneShotInfo] orig_oss SDoc ppr_orig_expr InScopeSet in_scope Type orig_ty = Int -> [OneShotInfo] -> Subst -> Type -> (InScopeSet, EtaInfo) go Int 0 [OneShotInfo] orig_oss Subst empty_subst Type orig_ty where empty_subst :: Subst empty_subst = InScopeSet -> Subst mkEmptySubst InScopeSet in_scope go :: Int -- For fresh names -> [OneShotInfo] -- Number of value args to expand to -> Subst -> Type -- We are really looking at subst(ty) -> (InScopeSet, EtaInfo) -- (go [o1,..,on] subst ty) = (in_scope, EI [b1,..,bn] co) -- co :: subst(ty) ~ b1_ty -> ... -> bn_ty -> tr go :: Int -> [OneShotInfo] -> Subst -> Type -> (InScopeSet, EtaInfo) go Int _ [] Subst subst Type _ ----------- Done! No more expansion needed = (Subst -> InScopeSet getSubstInScope Subst subst, [TyVar] -> MCoercionR -> EtaInfo EI [] MCoercionR MRefl) go Int n oss :: [OneShotInfo] oss@(OneShotInfo one_shot:[OneShotInfo] oss1) Subst subst Type ty ----------- Forall types (forall a. ty) | Just (Bndr TyVar tcv ForAllTyFlag vis, Type ty') <- Type -> Maybe (ForAllTyBinder, Type) splitForAllForAllTyBinder_maybe Type ty , (Subst subst', TyVar tcv') <- HasDebugCallStack => Subst -> TyVar -> (Subst, TyVar) Subst -> TyVar -> (Subst, TyVar) Type.substVarBndr Subst subst TyVar tcv , let oss' :: [OneShotInfo] oss' | TyVar -> Bool isTyVar TyVar tcv = [OneShotInfo] oss | Bool otherwise = [OneShotInfo] oss1 -- A forall can bind a CoVar, in which case -- we consume one of the [OneShotInfo] , (InScopeSet in_scope, EI [TyVar] bs MCoercionR mco) <- Int -> [OneShotInfo] -> Subst -> Type -> (InScopeSet, EtaInfo) go Int n [OneShotInfo] oss' Subst subst' Type ty' = (InScopeSet in_scope, [TyVar] -> MCoercionR -> EtaInfo EI (TyVar tcv' TyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] : [TyVar] bs) (ForAllTyBinder -> Type -> MCoercionR -> MCoercionR mkEtaForAllMCo (TyVar -> ForAllTyFlag -> ForAllTyBinder forall var argf. var -> argf -> VarBndr var argf Bndr TyVar tcv' ForAllTyFlag vis) Type ty' MCoercionR mco)) ----------- Function types (t1 -> t2) | Just (FunTyFlag _af, Type mult, Type arg_ty, Type res_ty) <- Type -> Maybe (FunTyFlag, Type, Type, Type) splitFunTy_maybe Type ty , HasDebugCallStack => Type -> Bool Type -> Bool typeHasFixedRuntimeRep Type arg_ty -- See Note [Representation polymorphism invariants] in GHC.Core -- See also test case typecheck/should_run/EtaExpandLevPoly , (Subst subst', TyVar eta_id) <- Int -> Subst -> Scaled Type -> (Subst, TyVar) freshEtaId Int n Subst subst (Type -> Type -> Scaled Type forall a. Type -> a -> Scaled a Scaled Type mult Type arg_ty) -- Avoid free vars of the original expression , let eta_id' :: TyVar eta_id' = TyVar eta_id TyVar -> OneShotInfo -> TyVar `setIdOneShotInfo` OneShotInfo one_shot , (InScopeSet in_scope, EI [TyVar] bs MCoercionR mco) <- Int -> [OneShotInfo] -> Subst -> Type -> (InScopeSet, EtaInfo) go (Int nInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) [OneShotInfo] oss1 Subst subst' Type res_ty = (InScopeSet in_scope, [TyVar] -> MCoercionR -> EtaInfo EI (TyVar eta_id' TyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] : [TyVar] bs) (TyVar -> MCoercionR -> MCoercionR mkFunResMCo TyVar eta_id' MCoercionR mco)) ----------- Newtypes -- 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) | Just (Coercion co, Type ty') <- Type -> Maybe (Coercion, Type) topNormaliseNewType_maybe Type ty , -- co :: ty ~ ty' let co' :: Coercion co' = HasDebugCallStack => Subst -> Coercion -> Coercion Subst -> Coercion -> Coercion Type.substCo Subst subst Coercion co -- Remember to apply the substitution to co (#16979) -- (or we could have applied to ty, but then -- we'd have had to zap it for the recursive call) , (InScopeSet in_scope, EI [TyVar] bs MCoercionR mco) <- Int -> [OneShotInfo] -> Subst -> Type -> (InScopeSet, EtaInfo) go Int n [OneShotInfo] oss Subst subst Type ty' -- mco :: subst(ty') ~ b1_ty -> ... -> bn_ty -> tr = (InScopeSet in_scope, [TyVar] -> MCoercionR -> EtaInfo EI [TyVar] bs (Coercion -> MCoercionR -> MCoercionR mkTransMCoR Coercion co' MCoercionR mco)) | Bool otherwise -- We have an expression of arity > 0, -- but its type isn't a function, or a binder -- does not have a fixed runtime representation = Bool -> String -> SDoc -> (InScopeSet, EtaInfo) -> (InScopeSet, EtaInfo) forall a. HasCallStack => Bool -> String -> SDoc -> a -> a warnPprTrace Bool True String "mkEtaWW" (([OneShotInfo] -> SDoc forall a. Outputable a => a -> SDoc ppr [OneShotInfo] orig_oss SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> Type -> SDoc forall a. Outputable a => a -> SDoc ppr Type orig_ty) SDoc -> SDoc -> SDoc forall doc. IsDoc doc => doc -> doc -> doc $$ SDoc ppr_orig_expr) (Subst -> InScopeSet getSubstInScope Subst subst, [TyVar] -> MCoercionR -> EtaInfo EI [] MCoercionR MRefl) -- This *can* legitimately 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 mkEtaForAllMCo :: ForAllTyBinder -> Type -> MCoercion -> MCoercion mkEtaForAllMCo :: ForAllTyBinder -> Type -> MCoercionR -> MCoercionR mkEtaForAllMCo (Bndr TyVar tcv ForAllTyFlag vis) Type ty MCoercionR mco = case MCoercionR mco of MCoercionR MRefl | ForAllTyFlag vis ForAllTyFlag -> ForAllTyFlag -> Bool forall a. Eq a => a -> a -> Bool == ForAllTyFlag coreTyLamForAllTyFlag -> MCoercionR MRefl | Bool otherwise -> Coercion -> MCoercionR mk_fco (Type -> Coercion mkRepReflCo Type ty) MCo Coercion co -> Coercion -> MCoercionR mk_fco Coercion co where mk_fco :: Coercion -> MCoercionR mk_fco Coercion co = Coercion -> MCoercionR MCo (HasDebugCallStack => TyVar -> ForAllTyFlag -> ForAllTyFlag -> Coercion -> Coercion -> Coercion TyVar -> ForAllTyFlag -> ForAllTyFlag -> Coercion -> Coercion -> Coercion mkForAllCo TyVar tcv ForAllTyFlag vis ForAllTyFlag coreTyLamForAllTyFlag (Type -> Coercion mkNomReflCo (TyVar -> Type varType TyVar tcv)) Coercion co) -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly -- the (EtaInfo Invariant). (sym co) wraps a lambda that always has -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core] -- in GHC.Core.TyCo.Rep {- ************************************************************************ * * Eta reduction * * ************************************************************************ Note [Eta reduction makes sense] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC's eta reduction transforms \x y. <fun> x y ---> <fun> We discuss when this is /sound/ in Note [Eta reduction soundness]. But even assuming it is sound, when is it /desirable/. That is what we discuss here. This test is made by `ok_fun` in tryEtaReduce. 1. We want to eta-reduce only if we get all the way to a trivial expression; we don't want to remove extra lambdas unless we are going to avoid allocating this thing altogether. Trivial means *including* casts and type lambdas: * `\x. f x |> co --> f |> (ty(x) -> co)` (provided `co` doesn't mention `x`) * `/\a. \x. f @(Maybe a) x --> /\a. f @(Maybe a)` See Note [Do not eta reduce PAPs] for why we insist on a trivial head. Of course, eta reduction is not always sound. See Note [Eta reduction soundness] for when it is. When there are multiple arguments, we might get multiple eta-redexes. Example: \x y. e x y ==> { reduce \y. (e x) y in context \x._ } \x. e x ==> { reduce \x. e x in context _ } e And (1) implies that we never want to stop with `\x. e x`, because that is not a trivial expression. So in practice, the implementation works by considering a whole group of leading lambdas to reduce. These delicacies are why we don't simply use 'exprIsTrivial' and 'exprIsHNF' in 'tryEtaReduce'. Alas. Note [Eta reduction soundness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC's eta reduction transforms \x y. <fun> x y ---> <fun> For soundness, we obviously require that `x` and `y` to not occur free. But what /other/ restrictions are there for eta reduction to be sound? We discuss separately what it means for eta reduction to be /desirable/, in Note [Eta reduction makes sense]. Eta reduction is *not* a sound transformation in general, because it may change termination behavior if *value* lambdas are involved: `bot` /= `\x. bot x` (as can be observed by a simple `seq`) The past has shown that oversight of this fact can not only lead to endless loops or exceptions, but also straight out *segfaults*. Nevertheless, we can give the following criteria for when it is sound to perform eta reduction on an expression with n leading lambdas `\xs. e xs` (checked in 'is_eta_reduction_sound' in 'tryEtaReduce', which focuses on the case where `e` is trivial): (A) It is sound to eta-reduce n arguments as long as n does not exceed the `exprArity` of `e`. (Needs Arity analysis.) This criterion exploits information about how `e` is *defined*. Example: If `e = \x. bot` then we know it won't diverge until it is called with one argument. Hence it is safe to eta-reduce `\x. e x` to `e`. By contrast, it would be *unsound* to eta-reduce 2 args, `\x y. e x y` to `e`: `e 42` diverges when `(\x y. e x y) 42` does not. (S) It is sound to eta-reduce n arguments in an evaluation context in which all calls happen with at least n arguments. (Needs Strictness analysis.) NB: This treats evaluations like a call with 0 args. NB: This criterion exploits information about how `e` is *used*. Example: Given a function `g` like `g c = Just (c 1 2 + c 2 3)` it is safe to eta-reduce the arg in `g (\x y. e x y)` to `g e` without knowing *anything* about `e` (perhaps it's a parameter occ itself), simply because `g` always calls its parameter with 2 arguments. It is also safe to eta-reduce just one arg, e.g., `g (\x. e x)` to `g e`. By contrast, it would *unsound* to eta-reduce 3 args in a call site like `g (\x y z. e x y z)` to `g e`, because that diverges when `e = \x y. bot`. Could we relax to "*At least one call in the same trace* is with n args"? No. Consider what happens for ``g2 c = c True `seq` c False 42`` Here, `g2` will call `c` with 2 arguments (if there is a call at all). But it is unsound to eta-reduce the arg in `g2 (\x y. e x y)` to `g2 e` when `e = \x. if x then bot else id`, because the latter will diverge when the former would not. Fortunately, the strictness analyser will report "Not always called with two arguments" for `g2` and we won't eta-expand. See Note [Eta reduction based on evaluation context] for the implementation details. This criterion is tested extensively in T21261. (R) Note [Eta reduction in recursive RHSs] tells us that we should not eta-reduce `f` in its own RHS and describes our fix. There we have `f = \x. f x` and we should not eta-reduce to `f=f`. Which might change a terminating program (think @f `seq` e@) to a non-terminating one. (E) (See fun_arity in tryEtaReduce.) As a perhaps special case on the boundary of (A) and (S), when we know that a fun binder `f` is in WHNF, we simply assume it has arity 1 and apply (A). Example: g f = f `seq` \x. f x Here it's sound eta-reduce `\x. f x` to `f`, because `f` can't be bottom after the `seq`. This turned up in #7542. T. If the binders are all type arguments, it's always safe to eta-reduce, regardless of the arity of f. /\a b. f @a @b --> f 2. Type and dictionary abstraction. Regardless of whether 'f' is a value, it is always sound to reduce /type lambdas/, thus: (/\a -> f a) --> f Moreover, we always want to, because it makes RULEs apply more often: This RULE: `forall g. foldr (build (/\a -> g a))` should match `foldr (build (/\b -> ...something complex...))` and the simplest way to do so is eta-reduce `/\a -> g a` in the RULE to `g`. More debatably, we extend this to dictionary arguments too, because the type checker can insert these eta-expanded versions, with both type and dictionary lambdas; hence the slightly ad-hoc (all ok_lam bndrs). That is, we eta-reduce \(d::Num a). f d --> f regardless of f's arity. Its not clear whether or not this is important, and it is not in general sound. But that's the way it is right now. And here are a few more technical criteria for when it is *not* sound to eta-reduce that are specific to Core and GHC: (J) We may not undersaturate join points. See Note [Invariants on join points] in GHC.Core, and #20599. (B) We may not undersaturate functions with no binding. See Note [Eta expanding primops]. (W) We may not undersaturate StrictWorkerIds. See Note [CBV Function Ids] in GHC.Types.Id.Info. Here is a list of historic accidents surrounding unsound eta-reduction: * Consider f = \x.f x h y = case (case y of { True -> f `seq` True; False -> False }) of True -> ...; False -> ... If we (unsoundly) eta-reduce f to get f=f, the strictness analyser says f=bottom, and replaces the (f `seq` True) with just (f `cast` unsafe-co). [SG in 2022: I don't think worker/wrapper would do this today.] BUT, as things stand, 'f' got arity 1, and it *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands the definition again, so that it does not terminate after all. Result: seg-fault because the boolean case actually gets a function value. See #1947. * Never *reduce* arity. For example f = \xy. g x y Then if h has arity 1 we don't want to eta-reduce because then f's arity would decrease, and that is bad [SG in 2022: I don't understand this point. There is no `h`, perhaps that should have been `g`. Even then, this proposed eta-reduction is invalid by criterion (A), which might actually be the point this anecdote is trying to make. Perhaps the "no arity decrease" idea is also related to Note [Arity robustness]?] Note [Do not eta reduce PAPs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ I considered eta-reducing if the result is a PAP: \x. f e1 e2 x ==> f e1 e2 This reduces clutter, sometimes a lot. See Note [Do not eta-expand PAPs] in GHC.Core.Opt.Simplify.Utils, where we are careful not to eta-expand a PAP. If eta-expanding is bad, then eta-reducing is good! Also the code generator likes eta-reduced PAPs; see GHC.CoreToStg.Prep Note [No eta reduction needed in rhsToBody]. But note that we don't want to eta-reduce \x y. f <expensive> x y to f <expensive> The former has arity 2, and repeats <expensive> for every call of the function; the latter has arity 0, and shares <expensive>. We don't want to change behaviour. Hence the call to exprIsCheap in ok_fun. I noticed this when examining #18993 and, although it is delicate, eta-reducing to a PAP happens to fix the regression in #18993. HOWEVER, if we transform \x. f y x ==> f y that might mean that f isn't saturated any more, and does not inline. This led to some other regressions. TL;DR currently we do /not/ eta reduce if the result is a PAP. Note [Eta reduction with casted arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (\(x:t3). f (x |> g)) :: t3 -> t2 where f :: t1 -> t2 g :: t3 ~ t1 This should be eta-reduced to f |> (sym g -> t2) So we need to accumulate a coercion, pushing it inward (past variable arguments only) thus: f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x f (x:t) |> co --> (f |> (t -> co)) x f @ a |> co --> (f |> (forall a.co)) @ a f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) These are the equations for ok_arg. Note [Eta reduction with casted function] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since we are pushing a coercion inwards, it is easy to accommodate (\xy. (f x |> g) y) (\xy. (f x y) |> g) See the `(Cast e co)` equation for `go` in `tryEtaReduce`. The eta-expander pushes those casts outwards, so you might think we won't ever see a cast here, but if we have \xy. (f x y |> g) we will call tryEtaReduce [x,y] (f x y |> g), and we'd like that to work. This happens in GHC.Core.Opt.Simplify.Utils.mkLam, where eta-expansion may be turned off (by sm_eta_expand). Note [Eta reduction based on evaluation context] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note [Eta reduction soundness], criterion (S) allows us to eta-reduce `g (\x y. e x y)` to `g e` when we know that `g` always calls its parameter with at least 2 arguments. So how do we read that off `g`'s demand signature? Let's take the simple example of #21261, where `g` (actually, `f`) is defined as g c = c 1 2 + c 3 4 Then this is how the pieces are put together: * Demand analysis infers `<SC(S,C(1,L))>` for `g`'s demand signature * When the Simplifier next simplifies the argument in `g (\x y. e x y)`, it looks up the *evaluation context* of the argument in the form of the sub-demand `C(S,C(1,L))` and stores it in the 'SimplCont'. (Why does it drop the outer evaluation cardinality of the demand, `S`? Because it's irrelevant! When we simplify an expression, we do so under the assumption that it is currently under evaluation.) This sub-demand literally says "Whenever this expression is evaluated, it is called with at least two arguments, potentially multiple times". * Then the simplifier takes apart the lambda and simplifies the lambda group and then calls 'tryEtaReduce' when rebuilding the lambda, passing the evaluation context `C(S,C(1,L))` along. Then we simply peel off 2 call sub-demands `Cn` and see whether all of the n's (here: `S=C_1N` and `1=C_11`) were strict. And strict they are! Thus, it will eta-reduce `\x y. e x y` to `e`. Note [Eta reduction in recursive RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following recursive function: f = \x. ....g (\y. f y).... The recursive call of f in its own RHS seems like a fine opportunity for eta-reduction because f has arity 1. And often it is! Alas, that is unsound in general if the eta-reduction happens in a tail context. Making the arity visible in the RHS allows us to eta-reduce f = \x -> f x to f = f which means we optimise terminating programs like (f `seq` ()) into non-terminating ones. Nor is this problem just for tail calls. Consider f = id (\x -> f x) where we have (for some reason) not yet inlined `id`. We must not eta-reduce to f = id f because that will then simplify to `f = f` as before. An immediate idea might be to look at whether the called function is a local loopbreaker and refrain from eta-expanding. But that doesn't work for mutually recursive function like in #21652: f = g g* x = f x Here, g* is the loopbreaker but f isn't. What can we do? Fix 1: Zap `idArity` when analysing recursive RHSs and re-attach the info when entering the let body. Has the disadvantage that other transformations which make use of arity (such as dropping of `seq`s when arity > 0) will no longer work in the RHS. Plus it requires non-trivial refactorings to both the simple optimiser (in the way `subst_opt_bndr` is used) as well as the Simplifier (in the way `simplRecBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's substitution twice in the process. A very complicated stop-gap. Fix 2: Pass the set of enclosing recursive binders to `tryEtaReduce`; these are the ones we should not eta-reduce. All call-site must maintain this set. Example: rec { f1 = ....rec { g = ... (\x. g x)...(\y. f2 y)... }... ; f2 = ...f1... } when eta-reducing those inner lambdas, we need to know that we are in the rec group for {f1, f2, g}. This is very much like the solution in Note [Speculative evaluation] in GHC.CoreToStg.Prep. It is a bit tiresome to maintain this info, because it means another field in SimplEnv and SimpleOptEnv. We implement Fix (2) because of it isn't as complicated to maintain as (1). Plus, it is the correct fix to begin with. After all, the arity is correct, but doing the transformation isn't. The moving parts are: * A field `scRecIds` in `SimplEnv` tracks the enclosing recursive binders * We extend the `scRecIds` set in `GHC.Core.Opt.Simplify.simplRecBind` * We consult the set in `is_eta_reduction_sound` in `tryEtaReduce` The situation is very similar to Note [Speculative evaluation] which has the same fix. -} -- | `tryEtaReduce [x,y,z] e sd` returns `Just e'` if `\x y z -> e` is evaluated -- according to `sd` and can soundly and gainfully be eta-reduced to `e'`. -- See Note [Eta reduction soundness] -- and Note [Eta reduction makes sense] when that is the case. tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> SubDemand -> Maybe CoreExpr -- Return an expression equal to (\bndrs. body) tryEtaReduce :: UnVarSet -> [TyVar] -> CoreExpr -> SubDemand -> Maybe CoreExpr tryEtaReduce UnVarSet rec_ids [TyVar] bndrs CoreExpr body SubDemand eval_sd = [TyVar] -> CoreExpr -> Coercion -> Maybe CoreExpr go ([TyVar] -> [TyVar] forall a. [a] -> [a] reverse [TyVar] bndrs) CoreExpr body (Type -> Coercion mkRepReflCo (HasDebugCallStack => CoreExpr -> Type CoreExpr -> Type exprType CoreExpr body)) where incoming_arity :: Int incoming_arity = (TyVar -> Bool) -> [TyVar] -> Int forall a. (a -> Bool) -> [a] -> Int count TyVar -> Bool isId [TyVar] bndrs -- See Note [Eta reduction makes sense], point (2) go :: [Var] -- Binders, innermost first, types [a3,a2,a1] -> CoreExpr -- Of type tr -> Coercion -- Of type tr ~ ts -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts -- See Note [Eta reduction with casted arguments] -- for why we have an accumulating coercion -- -- Invariant: (go bs body co) returns an expression -- equivalent to (\(reverse bs). (body |> co)) -- See Note [Eta reduction with casted function] go :: [TyVar] -> CoreExpr -> Coercion -> Maybe CoreExpr go [TyVar] bs (Cast CoreExpr e Coercion co1) Coercion co2 = [TyVar] -> CoreExpr -> Coercion -> Maybe CoreExpr go [TyVar] bs CoreExpr e (Coercion co1 Coercion -> Coercion -> Coercion `mkTransCo` Coercion co2) go [TyVar] bs (Tick CoreTickish t CoreExpr e) Coercion co | CoreTickish -> Bool forall (pass :: TickishPass). GenTickish pass -> Bool tickishFloatable CoreTickish t = (CoreExpr -> CoreExpr) -> Maybe CoreExpr -> Maybe CoreExpr forall a b. (a -> b) -> Maybe a -> Maybe b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (CoreTickish -> CoreExpr -> CoreExpr forall b. CoreTickish -> Expr b -> Expr b Tick CoreTickish t) (Maybe CoreExpr -> Maybe CoreExpr) -> Maybe CoreExpr -> Maybe CoreExpr forall a b. (a -> b) -> a -> b $ [TyVar] -> CoreExpr -> Coercion -> Maybe CoreExpr go [TyVar] bs CoreExpr e Coercion co -- Float app ticks: \x -> Tick t (e x) ==> Tick t e go (TyVar b : [TyVar] bs) (App CoreExpr fun CoreExpr arg) Coercion co | Just (Coercion co', [CoreTickish] ticks) <- TyVar -> CoreExpr -> Coercion -> Type -> Maybe (Coercion, [CoreTickish]) ok_arg TyVar b CoreExpr arg Coercion co (HasDebugCallStack => CoreExpr -> Type CoreExpr -> Type exprType CoreExpr fun) = (CoreExpr -> CoreExpr) -> Maybe CoreExpr -> Maybe CoreExpr forall a b. (a -> b) -> Maybe a -> Maybe b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ((CoreExpr -> [CoreTickish] -> CoreExpr) -> [CoreTickish] -> CoreExpr -> CoreExpr forall a b c. (a -> b -> c) -> b -> a -> c flip ((CoreTickish -> CoreExpr -> CoreExpr) -> CoreExpr -> [CoreTickish] -> CoreExpr forall a b. (a -> b -> b) -> b -> [a] -> b forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr CoreTickish -> CoreExpr -> CoreExpr mkTick) [CoreTickish] ticks) (Maybe CoreExpr -> Maybe CoreExpr) -> Maybe CoreExpr -> Maybe CoreExpr forall a b. (a -> b) -> a -> b $ [TyVar] -> CoreExpr -> Coercion -> Maybe CoreExpr go [TyVar] bs CoreExpr fun Coercion co' -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e go [TyVar] remaining_bndrs CoreExpr fun Coercion co | (TyVar -> Bool) -> [TyVar] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all TyVar -> Bool isTyVar [TyVar] remaining_bndrs -- If all the remaining_bnrs are tyvars, then the etad_exp -- will be trivial, which is what we want. -- e.g. We might have /\a \b. f [a] b, and we want to -- eta-reduce to /\a. f [a] -- We don't want to give up on this one: see #20040 -- See Note [Eta reduction makes sense], point (1) , [TyVar] remaining_bndrs [TyVar] -> [TyVar] -> Bool forall a b. [a] -> [b] -> Bool `ltLength` [TyVar] bndrs -- Only reply Just if /something/ has happened , CoreExpr -> Bool ok_fun CoreExpr fun , let used_vars :: VarSet used_vars = CoreExpr -> VarSet exprFreeVars CoreExpr fun VarSet -> VarSet -> VarSet `unionVarSet` Coercion -> VarSet tyCoVarsOfCo Coercion co reduced_bndrs :: VarSet reduced_bndrs = [TyVar] -> VarSet mkVarSet ([TyVar] -> [TyVar] -> [TyVar] forall b a. [b] -> [a] -> [a] dropList [TyVar] remaining_bndrs [TyVar] bndrs) -- reduced_bndrs are the ones we are eta-reducing away , VarSet used_vars VarSet -> VarSet -> Bool `disjointVarSet` VarSet reduced_bndrs -- Check for any of the reduced_bndrs (about to be dropped) -- free in the result, including the accumulated coercion. -- See Note [Eta reduction makes sense], intro and point (1) -- NB: don't compute used_vars from exprFreeVars (mkCast fun co) -- because the latter may be ill formed if the guard fails (#21801) = CoreExpr -> Maybe CoreExpr forall a. a -> Maybe a Just ([TyVar] -> CoreExpr -> CoreExpr forall b. [b] -> Expr b -> Expr b mkLams ([TyVar] -> [TyVar] forall a. [a] -> [a] reverse [TyVar] remaining_bndrs) (HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr CoreExpr -> Coercion -> CoreExpr mkCast CoreExpr fun Coercion co)) go [TyVar] _remaining_bndrs CoreExpr _fun Coercion _ = -- pprTrace "tER fail" (ppr _fun $$ ppr _remaining_bndrs) $ Maybe CoreExpr forall a. Maybe a Nothing --------------- -- See Note [Eta reduction makes sense], point (1) ok_fun :: CoreExpr -> Bool ok_fun (App CoreExpr fun (Type {})) = CoreExpr -> Bool ok_fun CoreExpr fun ok_fun (Cast CoreExpr fun Coercion _) = CoreExpr -> Bool ok_fun CoreExpr fun ok_fun (Tick CoreTickish _ CoreExpr expr) = CoreExpr -> Bool ok_fun CoreExpr expr ok_fun (Var TyVar fun_id) = TyVar -> Bool is_eta_reduction_sound TyVar fun_id ok_fun CoreExpr _fun = Bool False --------------- -- See Note [Eta reduction soundness], this is THE place to check soundness! is_eta_reduction_sound :: TyVar -> Bool is_eta_reduction_sound TyVar fun | TyVar fun TyVar -> UnVarSet -> Bool `elemUnVarSet` UnVarSet rec_ids -- Criterion (R) = Bool False -- Don't eta-reduce in fun in its own recursive RHSs | TyVar -> Bool cantEtaReduceFun TyVar fun -- Criteria (J), (W), (B) = Bool False -- Function can't be eta reduced to arity 0 -- without violating invariants of Core and GHC | Bool otherwise = -- Check that eta-reduction won't make the program stricter... TyVar -> Int fun_arity TyVar fun Int -> Int -> Bool forall a. Ord a => a -> a -> Bool >= Int incoming_arity -- Criterion (A) and (E) Bool -> Bool -> Bool || Int -> Bool all_calls_with_arity Int incoming_arity -- Criterion (S) Bool -> Bool -> Bool || (TyVar -> Bool) -> [TyVar] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all TyVar -> Bool ok_lam [TyVar] bndrs -- Criterion (T) all_calls_with_arity :: Int -> Bool all_calls_with_arity Int n = Card -> Bool isStrict ((Card, SubDemand) -> Card forall a b. (a, b) -> a fst ((Card, SubDemand) -> Card) -> (Card, SubDemand) -> Card forall a b. (a -> b) -> a -> b $ Int -> SubDemand -> (Card, SubDemand) peelManyCalls Int n SubDemand eval_sd) -- See Note [Eta reduction based on evaluation context] --------------- fun_arity :: TyVar -> Int fun_arity TyVar fun | Int arity Int -> Int -> Bool forall a. Ord a => a -> a -> Bool > Int 0 = Int arity | Unfolding -> Bool isEvaldUnfolding (IdUnfoldingFun idUnfolding TyVar fun) = Int 1 -- See Note [Eta reduction soundness], criterion (E) | Bool otherwise = Int 0 where arity :: Int arity = TyVar -> Int idArity TyVar fun --------------- ok_lam :: TyVar -> Bool ok_lam TyVar v = TyVar -> Bool isTyVar TyVar v Bool -> Bool -> Bool || TyVar -> Bool isEvVar TyVar v -- See Note [Eta reduction makes sense], point (2) --------------- ok_arg :: Var -- Of type bndr_t -> CoreExpr -- Of type arg_t -> Coercion -- Of kind (t1~t2) -> Type -- Type (arg_t -> t1) of the function -- to which the argument is supplied -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) -- (and similarly for tyvars, coercion args) , [CoreTickish]) -- See Note [Eta reduction with casted arguments] ok_arg :: TyVar -> CoreExpr -> Coercion -> Type -> Maybe (Coercion, [CoreTickish]) ok_arg TyVar bndr (Type Type arg_ty) Coercion co Type fun_ty | Just TyVar tv <- Type -> Maybe TyVar getTyVar_maybe Type arg_ty , TyVar bndr TyVar -> TyVar -> Bool forall a. Eq a => a -> a -> Bool == TyVar tv = case Type -> Maybe (ForAllTyBinder, Type) splitForAllForAllTyBinder_maybe Type fun_ty of Just (Bndr TyVar _ ForAllTyFlag vis, Type _) -> (Coercion, [CoreTickish]) -> Maybe (Coercion, [CoreTickish]) forall a. a -> Maybe a Just (Coercion fco, []) where !fco :: Coercion fco = HasDebugCallStack => TyVar -> ForAllTyFlag -> ForAllTyFlag -> Coercion -> Coercion -> Coercion TyVar -> ForAllTyFlag -> ForAllTyFlag -> Coercion -> Coercion -> Coercion mkForAllCo TyVar tv ForAllTyFlag vis ForAllTyFlag coreTyLamForAllTyFlag Coercion kco Coercion co -- The lambda we are eta-reducing always has visibility -- 'coreTyLamForAllTyFlag' which may or may not match -- the visibility on the inner function (#24014) kco :: Coercion kco = Type -> Coercion mkNomReflCo (TyVar -> Type tyVarKind TyVar tv) Maybe (ForAllTyBinder, Type) Nothing -> String -> SDoc -> Maybe (Coercion, [CoreTickish]) forall a. HasCallStack => String -> SDoc -> a pprPanic String "tryEtaReduce: type arg to non-forall type" (String -> SDoc forall doc. IsLine doc => String -> doc text String "fun:" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> TyVar -> SDoc forall a. Outputable a => a -> SDoc ppr TyVar bndr SDoc -> SDoc -> SDoc forall doc. IsDoc doc => doc -> doc -> doc $$ String -> SDoc forall doc. IsLine doc => String -> doc text String "arg:" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> Type -> SDoc forall a. Outputable a => a -> SDoc ppr Type arg_ty SDoc -> SDoc -> SDoc forall doc. IsDoc doc => doc -> doc -> doc $$ String -> SDoc forall doc. IsLine doc => String -> doc text String "fun_ty:" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> Type -> SDoc forall a. Outputable a => a -> SDoc ppr Type fun_ty) ok_arg TyVar bndr (Var TyVar v) Coercion co Type fun_ty | TyVar bndr TyVar -> TyVar -> Bool forall a. Eq a => a -> a -> Bool == TyVar v , let mult :: Type mult = TyVar -> Type idMult TyVar bndr , Just (FunTyFlag _af, Type fun_mult, Type _, Type _) <- Type -> Maybe (FunTyFlag, Type, Type, Type) splitFunTy_maybe Type fun_ty , Type mult HasCallStack => Type -> Type -> Bool Type -> Type -> Bool `eqType` Type fun_mult -- There is no change in multiplicity, otherwise we must abort = (Coercion, [CoreTickish]) -> Maybe (Coercion, [CoreTickish]) forall a. a -> Maybe a Just (Role -> TyVar -> Coercion -> Coercion mkFunResCo Role Representational TyVar bndr Coercion co, []) ok_arg TyVar bndr (Cast CoreExpr e Coercion co_arg) Coercion co Type fun_ty | ([CoreTickish] ticks, Var TyVar v) <- (CoreTickish -> Bool) -> CoreExpr -> ([CoreTickish], CoreExpr) forall b. (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b) stripTicksTop CoreTickish -> Bool forall (pass :: TickishPass). GenTickish pass -> Bool tickishFloatable CoreExpr e , Just (FunTyFlag _, Type fun_mult, Type _, Type _) <- Type -> Maybe (FunTyFlag, Type, Type, Type) splitFunTy_maybe Type fun_ty , TyVar bndr TyVar -> TyVar -> Bool forall a. Eq a => a -> a -> Bool == TyVar v , Type fun_mult HasCallStack => Type -> Type -> Bool Type -> Type -> Bool `eqType` TyVar -> Type idMult TyVar bndr = (Coercion, [CoreTickish]) -> Maybe (Coercion, [CoreTickish]) forall a. a -> Maybe a Just (HasDebugCallStack => Role -> Coercion -> Coercion -> Coercion -> Coercion Role -> Coercion -> Coercion -> Coercion -> Coercion mkFunCoNoFTF Role Representational (Type -> Coercion multToCo Type fun_mult) (Coercion -> Coercion mkSymCo Coercion co_arg) Coercion co, [CoreTickish] ticks) -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here ok_arg TyVar bndr (Tick CoreTickish t CoreExpr arg) Coercion co Type fun_ty | CoreTickish -> Bool forall (pass :: TickishPass). GenTickish pass -> Bool tickishFloatable CoreTickish t, Just (Coercion co', [CoreTickish] ticks) <- TyVar -> CoreExpr -> Coercion -> Type -> Maybe (Coercion, [CoreTickish]) ok_arg TyVar bndr CoreExpr arg Coercion co Type fun_ty = (Coercion, [CoreTickish]) -> Maybe (Coercion, [CoreTickish]) forall a. a -> Maybe a Just (Coercion co', CoreTickish tCoreTickish -> [CoreTickish] -> [CoreTickish] forall a. a -> [a] -> [a] :[CoreTickish] ticks) ok_arg TyVar _ CoreExpr _ Coercion _ Type _ = Maybe (Coercion, [CoreTickish]) forall a. Maybe a Nothing -- | Can we eta-reduce the given function -- See Note [Eta reduction soundness], criteria (B), (J), and (W). cantEtaReduceFun :: Id -> Bool cantEtaReduceFun :: TyVar -> Bool cantEtaReduceFun TyVar fun = TyVar -> Bool hasNoBinding TyVar fun -- (B) -- Don't undersaturate functions with no binding. Bool -> Bool -> Bool || TyVar -> Bool isJoinId TyVar fun -- (J) -- Don't undersaturate join points. -- See Note [Invariants on join points] in GHC.Core, and #20599 Bool -> Bool -> Bool || (Maybe [CbvMark] -> Bool forall a. Maybe a -> Bool isJust (TyVar -> Maybe [CbvMark] idCbvMarks_maybe TyVar fun)) -- (W) -- Don't undersaturate StrictWorkerIds. -- See Note [CBV Function Ids] in GHC.Types.Id.Info. {- ********************************************************************* * * The "push rules" * * ************************************************************************ Here we implement the "push rules" from FC papers: * The push-argument rules, where we can move a coercion past an argument. We have (fun |> co) arg and we want to transform it to (fun arg') |> co' for some suitable co' and transformed arg'. * The PushK rule for data constructors. We have (K e1 .. en) |> co and we want to transform to (K e1' .. en') by pushing the coercion into the arguments -} pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) pushCoArgs :: Coercion -> [CoreExpr] -> Maybe ([CoreExpr], MCoercionR) pushCoArgs Coercion co [] = ([CoreExpr], MCoercionR) -> Maybe ([CoreExpr], MCoercionR) forall a. a -> Maybe a forall (m :: * -> *) a. Monad m => a -> m a return ([], Coercion -> MCoercionR MCo Coercion co) pushCoArgs Coercion co (CoreExpr arg:[CoreExpr] args) = do { (arg', m_co1) <- Coercion -> CoreExpr -> Maybe (CoreExpr, MCoercionR) pushCoArg Coercion co CoreExpr arg ; case m_co1 of MCo Coercion co1 -> do { (args', m_co2) <- Coercion -> [CoreExpr] -> Maybe ([CoreExpr], MCoercionR) pushCoArgs Coercion co1 [CoreExpr] args ; return (arg':args', m_co2) } MCoercionR MRefl -> ([CoreExpr], MCoercionR) -> Maybe ([CoreExpr], MCoercionR) forall a. a -> Maybe a forall (m :: * -> *) a. Monad m => a -> m a return (CoreExpr arg'CoreExpr -> [CoreExpr] -> [CoreExpr] forall a. a -> [a] -> [a] :[CoreExpr] args, MCoercionR MRefl) } pushMCoArg :: MCoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) pushMCoArg :: MCoercionR -> CoreExpr -> Maybe (CoreExpr, MCoercionR) pushMCoArg MCoercionR MRefl CoreExpr arg = (CoreExpr, MCoercionR) -> Maybe (CoreExpr, MCoercionR) forall a. a -> Maybe a Just (CoreExpr arg, MCoercionR MRefl) pushMCoArg (MCo Coercion co) CoreExpr arg = Coercion -> CoreExpr -> Maybe (CoreExpr, MCoercionR) pushCoArg Coercion co CoreExpr arg pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) -- We have (fun |> co) arg, and we want to transform it to -- (fun arg) |> co -- This may fail, e.g. if (fun :: N) where N is a newtype -- C.f. simplCast in GHC.Core.Opt.Simplify -- 'co' is always Representational pushCoArg :: Coercion -> CoreExpr -> Maybe (CoreExpr, MCoercionR) pushCoArg Coercion co CoreExpr arg | Type Type ty <- CoreExpr arg = do { (ty', m_co') <- Coercion -> Type -> Maybe (Type, MCoercionR) pushCoTyArg Coercion co Type ty ; return (Type ty', m_co') } | Bool otherwise = do { (arg_mco, m_co') <- Coercion -> Maybe (MCoercionR, MCoercionR) pushCoValArg Coercion co ; let arg_mco' = MCoercionR -> MCoercionR checkReflexiveMCo MCoercionR arg_mco -- checkReflexiveMCo: see Note [Check for reflexive casts in eta expansion] -- The coercion is very often (arg_co -> res_co), but without -- the argument coercion actually being ReflCo ; return (arg `mkCastMCo` arg_mco', m_co') } pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) -- We have (fun |> co) @ty -- Push the coercion through to return -- (fun @ty') |> co' -- 'co' is always Representational -- If the returned coercion is Nothing, then it would have been reflexive; -- it's faster not to compute it, though. pushCoTyArg :: Coercion -> Type -> Maybe (Type, MCoercionR) pushCoTyArg Coercion co Type ty -- The following is inefficient - don't do `eqType` here, the coercion -- optimizer will take care of it. See #14737. -- -- | tyL `eqType` tyR -- -- = Just (ty, Nothing) | Coercion -> Bool isReflCo Coercion co = (Type, MCoercionR) -> Maybe (Type, MCoercionR) forall a. a -> Maybe a Just (Type ty, MCoercionR MRefl) | Type -> Bool isForAllTy_ty Type tyL = Bool -> SDoc -> Maybe (Type, MCoercionR) -> Maybe (Type, MCoercionR) forall a. HasCallStack => Bool -> SDoc -> a -> a assertPpr (Type -> Bool isForAllTy_ty Type tyR) (Coercion -> SDoc forall a. Outputable a => a -> SDoc ppr Coercion co SDoc -> SDoc -> SDoc forall doc. IsDoc doc => doc -> doc -> doc $$ Type -> SDoc forall a. Outputable a => a -> SDoc ppr Type ty) (Maybe (Type, MCoercionR) -> Maybe (Type, MCoercionR)) -> Maybe (Type, MCoercionR) -> Maybe (Type, MCoercionR) forall a b. (a -> b) -> a -> b $ (Type, MCoercionR) -> Maybe (Type, MCoercionR) forall a. a -> Maybe a Just (Type ty Type -> Coercion -> Type `mkCastTy` Coercion co1, Coercion -> MCoercionR MCo Coercion co2) | Bool otherwise = Maybe (Type, MCoercionR) forall a. Maybe a Nothing where Pair Type tyL Type tyR = Coercion -> Pair Type coercionKind Coercion co -- co :: tyL ~R tyR -- tyL = forall (a1 :: k1). ty1 -- tyR = forall (a2 :: k2). ty2 co1 :: Coercion co1 = Coercion -> Coercion mkSymCo (HasDebugCallStack => CoSel -> Coercion -> Coercion CoSel -> Coercion -> Coercion mkSelCo CoSel SelForAll Coercion co) -- co1 :: k2 ~N k1 -- Note that SelCo extracts a Nominal equality between the -- kinds of the types related by a coercion between forall-types. -- See the SelCo case in GHC.Core.Lint. co2 :: Coercion co2 = Coercion -> Coercion -> Coercion mkInstCo Coercion co (Role -> Type -> Coercion -> Coercion mkGReflLeftCo Role Nominal Type ty Coercion co1) -- co2 :: ty1[ (ty|>co1)/a1 ] ~R ty2[ ty/a2 ] -- Arg of mkInstCo is always nominal, hence Nominal -- | If @pushCoValArg co = Just (co_arg, co_res)@, then -- -- > (\x.body) |> co = (\y. let { x = y |> co_arg } in body) |> co_res) -- -- or, equivalently -- -- > (fun |> co) arg = (fun (arg |> co_arg)) |> co_res -- -- If the LHS is well-typed, then so is the RHS. In particular, the argument -- @arg |> co_arg@ is guaranteed to have a fixed 'RuntimeRep', in the sense of -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR) pushCoValArg :: Coercion -> Maybe (MCoercionR, MCoercionR) pushCoValArg Coercion co -- The following is inefficient - don't do `eqType` here, the coercion -- optimizer will take care of it. See #14737. -- -- | tyL `eqType` tyR -- -- = Just (mkRepReflCo arg, Nothing) | Coercion -> Bool isReflCo Coercion co = (MCoercionR, MCoercionR) -> Maybe (MCoercionR, MCoercionR) forall a. a -> Maybe a Just (MCoercionR MRefl, MCoercionR MRefl) | Type -> Bool isFunTy Type tyL , (Coercion _, Coercion co1, Coercion co2) <- HasDebugCallStack => Coercion -> (Coercion, Coercion, Coercion) Coercion -> (Coercion, Coercion, Coercion) decomposeFunCo Coercion co -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) -- then co1 :: tyL1 ~ tyR1 -- co2 :: tyL2 ~ tyR2 , HasDebugCallStack => Type -> Bool Type -> Bool typeHasFixedRuntimeRep Type new_arg_ty -- We can't push the coercion inside if it would give rise to -- a representation-polymorphic argument. = Bool -> SDoc -> Maybe (MCoercionR, MCoercionR) -> Maybe (MCoercionR, MCoercionR) forall a. HasCallStack => Bool -> SDoc -> a -> a assertPpr (Type -> Bool isFunTy Type tyL Bool -> Bool -> Bool && Type -> Bool isFunTy Type tyR) ([SDoc] -> SDoc forall doc. IsDoc doc => [doc] -> doc vcat [ String -> SDoc forall doc. IsLine doc => String -> doc text String "co:" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> Coercion -> SDoc forall a. Outputable a => a -> SDoc ppr Coercion co , String -> SDoc forall doc. IsLine doc => String -> doc text String "old_arg_ty:" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> Type -> SDoc forall a. Outputable a => a -> SDoc ppr Type old_arg_ty , String -> SDoc forall doc. IsLine doc => String -> doc text String "new_arg_ty:" SDoc -> SDoc -> SDoc forall doc. IsLine doc => doc -> doc -> doc <+> Type -> SDoc forall a. Outputable a => a -> SDoc ppr Type new_arg_ty ]) (Maybe (MCoercionR, MCoercionR) -> Maybe (MCoercionR, MCoercionR)) -> Maybe (MCoercionR, MCoercionR) -> Maybe (MCoercionR, MCoercionR) forall a b. (a -> b) -> a -> b $ (MCoercionR, MCoercionR) -> Maybe (MCoercionR, MCoercionR) forall a. a -> Maybe a Just (Coercion -> MCoercionR coToMCo (Coercion -> Coercion mkSymCo Coercion co1), Coercion -> MCoercionR coToMCo Coercion co2) -- Critically, coToMCo to checks for ReflCo; the whole coercion may not -- be reflexive, but either of its components might be -- We could use isReflexiveCo, but it's not clear if the benefit -- is worth the cost, and it makes no difference in #18223 | Bool otherwise = Maybe (MCoercionR, MCoercionR) forall a. Maybe a Nothing where old_arg_ty :: Type old_arg_ty = HasDebugCallStack => Type -> Type Type -> Type funArgTy Type tyR new_arg_ty :: Type new_arg_ty = HasDebugCallStack => Type -> Type Type -> Type funArgTy Type tyL Pair Type tyL Type tyR = Coercion -> Pair Type coercionKind Coercion co pushCoercionIntoLambda :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) -- This implements the Push rule from the paper on coercions -- (\x. e) |> co -- ===> -- (\x'. e |> co') pushCoercionIntoLambda :: HasDebugCallStack => InScopeSet -> TyVar -> CoreExpr -> Coercion -> Maybe (TyVar, CoreExpr) pushCoercionIntoLambda InScopeSet in_scope TyVar x CoreExpr e Coercion co | Bool -> Bool -> Bool forall a. HasCallStack => Bool -> a -> a assert (Bool -> Bool not (TyVar -> Bool isTyVar TyVar x) Bool -> Bool -> Bool && Bool -> Bool not (TyVar -> Bool isCoVar TyVar x)) Bool True , Pair Type s1s2 Type t1t2 <- Coercion -> Pair Type coercionKind Coercion co , Just {} <- Type -> Maybe (FunTyFlag, Type, Type, Type) splitFunTy_maybe Type s1s2 , Just (FunTyFlag _, Type w1, Type t1,Type _t2) <- Type -> Maybe (FunTyFlag, Type, Type, Type) splitFunTy_maybe Type t1t2 , (Coercion _, Coercion co1, Coercion co2) <- HasDebugCallStack => Coercion -> (Coercion, Coercion, Coercion) Coercion -> (Coercion, Coercion, Coercion) decomposeFunCo Coercion co , HasDebugCallStack => Type -> Bool Type -> Bool typeHasFixedRuntimeRep Type t1 -- We can't push the coercion into the lambda if it would create -- a representation-polymorphic binder. = let -- Should we optimize the coercions here? -- Otherwise they might not match too well x' :: TyVar x' = TyVar x TyVar -> Type -> TyVar `setIdType` Type t1 TyVar -> Type -> TyVar `setIdMult` Type w1 in_scope' :: InScopeSet in_scope' = InScopeSet in_scope InScopeSet -> TyVar -> InScopeSet `extendInScopeSet` TyVar x' subst :: Subst subst = Subst -> TyVar -> CoreExpr -> Subst extendIdSubst (InScopeSet -> Subst mkEmptySubst InScopeSet in_scope') TyVar x (HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr CoreExpr -> Coercion -> CoreExpr mkCast (TyVar -> CoreExpr forall b. TyVar -> Expr b Var TyVar x') (Coercion -> Coercion mkSymCo Coercion co1)) -- We substitute x' for x, except we need to preserve types. -- The types are as follows: -- x :: s1, x' :: t1, co1 :: s1 ~# t1, -- so we extend the substitution with x |-> (x' |> sym co1). in (TyVar, CoreExpr) -> Maybe (TyVar, CoreExpr) forall a. a -> Maybe a Just (TyVar x', HasDebugCallStack => Subst -> CoreExpr -> CoreExpr Subst -> CoreExpr -> CoreExpr substExpr Subst subst CoreExpr e HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr CoreExpr -> Coercion -> CoreExpr `mkCast` Coercion co2) | Bool otherwise = Maybe (TyVar, CoreExpr) forall a. Maybe a Nothing pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercion -> Maybe (DataCon , [Type] -- Universal type args , [CoreExpr]) -- All other args incl existentials -- Implement the KPush reduction rule as described in "Down with kinds" -- The transformation applies iff we have -- (C e1 ... en) `cast` co -- where co :: (T t1 .. tn) ~ to_ty -- The left-hand one must be a T, because exprIsConApp returned True -- but the right-hand one might not be. (Though it usually will.) pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercionR -> Maybe (DataCon, [Type], [CoreExpr]) pushCoDataCon DataCon dc [CoreExpr] dc_args MCoercionR MRefl = (DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr]) forall a. a -> Maybe a Just ((DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr])) -> (DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr]) forall a b. (a -> b) -> a -> b $! (DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr]) push_dc_refl DataCon dc [CoreExpr] dc_args) pushCoDataCon DataCon dc [CoreExpr] dc_args (MCo Coercion co) = DataCon -> [CoreExpr] -> Coercion -> Pair Type -> Maybe (DataCon, [Type], [CoreExpr]) push_dc_gen DataCon dc [CoreExpr] dc_args Coercion co (Coercion -> Pair Type coercionKind Coercion co) push_dc_refl :: DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr]) push_dc_refl :: DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr]) push_dc_refl DataCon dc [CoreExpr] dc_args = (DataCon dc, (CoreExpr -> Type) -> [CoreExpr] -> [Type] forall a b. (a -> b) -> [a] -> [b] map CoreExpr -> Type exprToType [CoreExpr] univ_ty_args, [CoreExpr] rest_args) where !([CoreExpr] univ_ty_args, [CoreExpr] rest_args) = [TyVar] -> [CoreExpr] -> ([CoreExpr], [CoreExpr]) forall b a. [b] -> [a] -> ([a], [a]) splitAtList (DataCon -> [TyVar] dataConUnivTyVars DataCon dc) [CoreExpr] dc_args push_dc_gen :: DataCon -> [CoreExpr] -> Coercion -> Pair Type -> Maybe (DataCon, [Type], [CoreExpr]) push_dc_gen :: DataCon -> [CoreExpr] -> Coercion -> Pair Type -> Maybe (DataCon, [Type], [CoreExpr]) push_dc_gen DataCon dc [CoreExpr] dc_args Coercion co (Pair Type from_ty Type to_ty) | Type from_ty HasCallStack => Type -> Type -> Bool Type -> Type -> Bool `eqType` Type to_ty -- try cheap test first = (DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr]) forall a. a -> Maybe a Just ((DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr])) -> (DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr]) forall a b. (a -> b) -> a -> b $! (DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr]) push_dc_refl DataCon dc [CoreExpr] dc_args) | Just (TyCon to_tc, [Type] to_tc_arg_tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type]) Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe Type to_ty , TyCon to_tc TyCon -> TyCon -> Bool forall a. Eq a => a -> a -> Bool == DataCon -> TyCon dataConTyCon DataCon dc -- These two tests can fail; we might see -- (C x y) `cast` (g :: T a ~ S [a]), -- where S is a type function. In fact, exprIsConApp -- will probably not be called in such circumstances, -- but there's nothing wrong with it = let tc_arity :: Int tc_arity = TyCon -> Int tyConArity TyCon to_tc dc_univ_tyvars :: [TyVar] dc_univ_tyvars = DataCon -> [TyVar] dataConUnivTyVars DataCon dc dc_ex_tcvars :: [TyVar] dc_ex_tcvars = DataCon -> [TyVar] dataConExTyCoVars DataCon dc arg_tys :: [Scaled Type] arg_tys = DataCon -> [Scaled Type] dataConRepArgTys DataCon dc non_univ_args :: [CoreExpr] non_univ_args = [TyVar] -> [CoreExpr] -> [CoreExpr] forall b a. [b] -> [a] -> [a] dropList [TyVar] dc_univ_tyvars [CoreExpr] dc_args ([CoreExpr] ex_args, [CoreExpr] val_args) = [TyVar] -> [CoreExpr] -> ([CoreExpr], [CoreExpr]) forall b a. [b] -> [a] -> ([a], [a]) splitAtList [TyVar] dc_ex_tcvars [CoreExpr] non_univ_args -- Make the "Psi" from the paper omegas :: [Coercion] omegas = Int -> Coercion -> Infinite Role -> [Coercion] decomposeCo Int tc_arity Coercion co (TyCon -> Infinite Role tyConRolesRepresentational TyCon to_tc) (Type -> Coercion psi_subst, [Type] to_ex_arg_tys) = Role -> [TyVar] -> [Coercion] -> [TyVar] -> [Type] -> (Type -> Coercion, [Type]) liftCoSubstWithEx Role Representational [TyVar] dc_univ_tyvars [Coercion] omegas [TyVar] dc_ex_tcvars ((CoreExpr -> Type) -> [CoreExpr] -> [Type] forall a b. (a -> b) -> [a] -> [b] map CoreExpr -> Type exprToType [CoreExpr] ex_args) -- Cast the value arguments (which include dictionaries) new_val_args :: [CoreExpr] new_val_args = (Type -> CoreExpr -> CoreExpr) -> [Type] -> [CoreExpr] -> [CoreExpr] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith Type -> CoreExpr -> CoreExpr cast_arg ((Scaled Type -> Type) -> [Scaled Type] -> [Type] forall a b. (a -> b) -> [a] -> [b] map Scaled Type -> Type forall a. Scaled a -> a scaledThing [Scaled Type] arg_tys) [CoreExpr] val_args cast_arg :: Type -> CoreExpr -> CoreExpr cast_arg Type arg_ty CoreExpr arg = HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr CoreExpr -> Coercion -> CoreExpr mkCast CoreExpr arg (Type -> Coercion psi_subst Type arg_ty) to_ex_args :: [CoreExpr] to_ex_args = (Type -> CoreExpr) -> [Type] -> [CoreExpr] forall a b. (a -> b) -> [a] -> [b] map Type -> CoreExpr forall b. Type -> Expr b Type [Type] to_ex_arg_tys dump_doc :: SDoc dump_doc = [SDoc] -> SDoc forall doc. IsDoc doc => [doc] -> doc vcat [DataCon -> SDoc forall a. Outputable a => a -> SDoc ppr DataCon dc, [TyVar] -> SDoc forall a. Outputable a => a -> SDoc ppr [TyVar] dc_univ_tyvars, [TyVar] -> SDoc forall a. Outputable a => a -> SDoc ppr [TyVar] dc_ex_tcvars, [Scaled Type] -> SDoc forall a. Outputable a => a -> SDoc ppr [Scaled Type] arg_tys, [CoreExpr] -> SDoc forall a. Outputable a => a -> SDoc ppr [CoreExpr] dc_args, [CoreExpr] -> SDoc forall a. Outputable a => a -> SDoc ppr [CoreExpr] ex_args, [CoreExpr] -> SDoc forall a. Outputable a => a -> SDoc ppr [CoreExpr] val_args, Coercion -> SDoc forall a. Outputable a => a -> SDoc ppr Coercion co, Type -> SDoc forall a. Outputable a => a -> SDoc ppr Type from_ty, Type -> SDoc forall a. Outputable a => a -> SDoc ppr Type to_ty, TyCon -> SDoc forall a. Outputable a => a -> SDoc ppr TyCon to_tc , Type -> SDoc forall a. Outputable a => a -> SDoc ppr (Type -> SDoc) -> Type -> SDoc forall a b. (a -> b) -> a -> b $ TyCon -> [Type] -> Type mkTyConApp TyCon to_tc ((CoreExpr -> Type) -> [CoreExpr] -> [Type] forall a b. (a -> b) -> [a] -> [b] map CoreExpr -> Type exprToType ([CoreExpr] -> [Type]) -> [CoreExpr] -> [Type] forall a b. (a -> b) -> a -> b $ [TyVar] -> [CoreExpr] -> [CoreExpr] forall b a. [b] -> [a] -> [a] takeList [TyVar] dc_univ_tyvars [CoreExpr] dc_args) ] in Bool -> SDoc -> Maybe (DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr]) forall a. HasCallStack => Bool -> SDoc -> a -> a assertPpr (HasCallStack => Type -> Type -> Bool Type -> Type -> Bool eqType Type from_ty (TyCon -> [Type] -> Type mkTyConApp TyCon to_tc ((CoreExpr -> Type) -> [CoreExpr] -> [Type] forall a b. (a -> b) -> [a] -> [b] map CoreExpr -> Type exprToType ([CoreExpr] -> [Type]) -> [CoreExpr] -> [Type] forall a b. (a -> b) -> a -> b $ [TyVar] -> [CoreExpr] -> [CoreExpr] forall b a. [b] -> [a] -> [a] takeList [TyVar] dc_univ_tyvars [CoreExpr] dc_args))) SDoc dump_doc (Maybe (DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr])) -> Maybe (DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr]) forall a b. (a -> b) -> a -> b $ Bool -> SDoc -> Maybe (DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr]) forall a. HasCallStack => Bool -> SDoc -> a -> a assertPpr ([CoreExpr] -> [Scaled Type] -> Bool forall a b. [a] -> [b] -> Bool equalLength [CoreExpr] val_args [Scaled Type] arg_tys) SDoc dump_doc (Maybe (DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr])) -> Maybe (DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr]) forall a b. (a -> b) -> a -> b $ (DataCon, [Type], [CoreExpr]) -> Maybe (DataCon, [Type], [CoreExpr]) forall a. a -> Maybe a Just (DataCon dc, [Type] to_tc_arg_tys, [CoreExpr] to_ex_args [CoreExpr] -> [CoreExpr] -> [CoreExpr] forall a. [a] -> [a] -> [a] ++ [CoreExpr] new_val_args) | Bool otherwise = Maybe (DataCon, [Type], [CoreExpr]) forall a. Maybe a Nothing collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) -- Collect lambda binders, pushing coercions inside if possible -- E.g. (\x.e) |> g g :: <Int> -> blah -- = (\x. e |> SelCo (SelFun SelRes) g) -- -- That is, -- -- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> SelCo (SelFun SelRes) g) collectBindersPushingCo :: CoreExpr -> ([TyVar], CoreExpr) collectBindersPushingCo CoreExpr e = [TyVar] -> CoreExpr -> ([TyVar], CoreExpr) go [] CoreExpr e where -- Peel off lambdas until we hit a cast. go :: [Var] -> CoreExpr -> ([Var], CoreExpr) -- The accumulator is in reverse order go :: [TyVar] -> CoreExpr -> ([TyVar], CoreExpr) go [TyVar] bs (Lam TyVar b CoreExpr e) = [TyVar] -> CoreExpr -> ([TyVar], CoreExpr) go (TyVar bTyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] :[TyVar] bs) CoreExpr e go [TyVar] bs (Cast CoreExpr e Coercion co) = [TyVar] -> CoreExpr -> Coercion -> ([TyVar], CoreExpr) go_c [TyVar] bs CoreExpr e Coercion co go [TyVar] bs CoreExpr e = ([TyVar] -> [TyVar] forall a. [a] -> [a] reverse [TyVar] bs, CoreExpr e) -- We are in a cast; peel off casts until we hit a lambda. go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr) -- (go_c bs e c) is same as (go bs e (e |> c)) go_c :: [TyVar] -> CoreExpr -> Coercion -> ([TyVar], CoreExpr) go_c [TyVar] bs (Cast CoreExpr e Coercion co1) Coercion co2 = [TyVar] -> CoreExpr -> Coercion -> ([TyVar], CoreExpr) go_c [TyVar] bs CoreExpr e (Coercion co1 Coercion -> Coercion -> Coercion `mkTransCo` Coercion co2) go_c [TyVar] bs (Lam TyVar b CoreExpr e) Coercion co = [TyVar] -> TyVar -> CoreExpr -> Coercion -> ([TyVar], CoreExpr) go_lam [TyVar] bs TyVar b CoreExpr e Coercion co go_c [TyVar] bs CoreExpr e Coercion co = ([TyVar] -> [TyVar] forall a. [a] -> [a] reverse [TyVar] bs, HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr CoreExpr -> Coercion -> CoreExpr mkCast CoreExpr e Coercion co) -- We are in a lambda under a cast; peel off lambdas and build a -- new coercion for the body. go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr) -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) go_lam :: [TyVar] -> TyVar -> CoreExpr -> Coercion -> ([TyVar], CoreExpr) go_lam [TyVar] bs TyVar b CoreExpr e Coercion co | TyVar -> Bool isTyVar TyVar b , let Pair Type tyL Type tyR = Coercion -> Pair Type coercionKind Coercion co , Bool -> Bool -> Bool forall a. HasCallStack => Bool -> a -> a assert (Type -> Bool isForAllTy_ty Type tyL) (Bool -> Bool) -> Bool -> Bool forall a b. (a -> b) -> a -> b $ Type -> Bool isForAllTy_ty Type tyR , Coercion -> Bool isReflCo (HasDebugCallStack => CoSel -> Coercion -> Coercion CoSel -> Coercion -> Coercion mkSelCo CoSel SelForAll Coercion co) -- See Note [collectBindersPushingCo] = [TyVar] -> CoreExpr -> Coercion -> ([TyVar], CoreExpr) go_c (TyVar bTyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] :[TyVar] bs) CoreExpr e (Coercion -> Coercion -> Coercion mkInstCo Coercion co (Type -> Coercion mkNomReflCo (TyVar -> Type mkTyVarTy TyVar b))) | TyVar -> Bool isCoVar TyVar b , let Pair Type tyL Type tyR = Coercion -> Pair Type coercionKind Coercion co , Bool -> Bool -> Bool forall a. HasCallStack => Bool -> a -> a assert (Type -> Bool isForAllTy_co Type tyL) (Bool -> Bool) -> Bool -> Bool forall a b. (a -> b) -> a -> b $ Type -> Bool isForAllTy_co Type tyR , Coercion -> Bool isReflCo (HasDebugCallStack => CoSel -> Coercion -> Coercion CoSel -> Coercion -> Coercion mkSelCo CoSel SelForAll Coercion co) -- See Note [collectBindersPushingCo] , let cov :: Coercion cov = TyVar -> Coercion mkCoVarCo TyVar b = [TyVar] -> CoreExpr -> Coercion -> ([TyVar], CoreExpr) go_c (TyVar bTyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] :[TyVar] bs) CoreExpr e (Coercion -> Coercion -> Coercion mkInstCo Coercion co (Type -> Coercion mkNomReflCo (Coercion -> Type mkCoercionTy Coercion cov))) | TyVar -> Bool isId TyVar b , let Pair Type tyL Type tyR = Coercion -> Pair Type coercionKind Coercion co , Bool -> Bool -> Bool forall a. HasCallStack => Bool -> a -> a assert (Type -> Bool isFunTy Type tyL) (Bool -> Bool) -> Bool -> Bool forall a b. (a -> b) -> a -> b $ Type -> Bool isFunTy Type tyR , (Coercion co_mult, Coercion co_arg, Coercion co_res) <- HasDebugCallStack => Coercion -> (Coercion, Coercion, Coercion) Coercion -> (Coercion, Coercion, Coercion) decomposeFunCo Coercion co , Coercion -> Bool isReflCo Coercion co_mult -- See Note [collectBindersPushingCo] , Coercion -> Bool isReflCo Coercion co_arg -- See Note [collectBindersPushingCo] = [TyVar] -> CoreExpr -> Coercion -> ([TyVar], CoreExpr) go_c (TyVar bTyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] :[TyVar] bs) CoreExpr e Coercion co_res | Bool otherwise = ([TyVar] -> [TyVar] forall a. [a] -> [a] reverse [TyVar] bs, HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr CoreExpr -> Coercion -> CoreExpr mkCast (TyVar -> CoreExpr -> CoreExpr forall b. b -> Expr b -> Expr b Lam TyVar b CoreExpr e) Coercion co) {- Note [collectBindersPushingCo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We just look for coercions of form <type> % w -> blah (and similarly for foralls) to keep this function simple. We could do more elaborate stuff, but it'd involve substitution etc. -} {- ********************************************************************* * * Join points * * ********************************************************************* -} ------------------- -- | Split an expression into the given number of binders and a body, -- eta-expanding if necessary. Counts value *and* type binders. etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) etaExpandToJoinPoint :: Int -> CoreExpr -> ([TyVar], CoreExpr) etaExpandToJoinPoint Int join_arity CoreExpr expr = Int -> [TyVar] -> CoreExpr -> ([TyVar], CoreExpr) go Int join_arity [] CoreExpr expr where go :: Int -> [TyVar] -> CoreExpr -> ([TyVar], CoreExpr) go Int 0 [TyVar] rev_bs CoreExpr e = ([TyVar] -> [TyVar] forall a. [a] -> [a] reverse [TyVar] rev_bs, CoreExpr e) go Int n [TyVar] rev_bs (Lam TyVar b CoreExpr e) = Int -> [TyVar] -> CoreExpr -> ([TyVar], CoreExpr) go (Int nInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) (TyVar b TyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] : [TyVar] rev_bs) CoreExpr e go Int n [TyVar] rev_bs CoreExpr e = case Int -> CoreExpr -> ([TyVar], CoreExpr) etaBodyForJoinPoint Int n CoreExpr e of ([TyVar] bs, CoreExpr e') -> ([TyVar] -> [TyVar] forall a. [a] -> [a] reverse [TyVar] rev_bs [TyVar] -> [TyVar] -> [TyVar] forall a. [a] -> [a] -> [a] ++ [TyVar] bs, CoreExpr e') etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule etaExpandToJoinPointRule :: Int -> CoreRule -> CoreRule etaExpandToJoinPointRule Int _ rule :: CoreRule rule@(BuiltinRule {}) = Bool -> String -> SDoc -> CoreRule -> CoreRule forall a. HasCallStack => Bool -> String -> SDoc -> a -> a warnPprTrace Bool True String "Can't eta-expand built-in rule:" (CoreRule -> SDoc forall a. Outputable a => a -> SDoc ppr CoreRule rule) -- How did a local binding get a built-in rule anyway? Probably a plugin. CoreRule rule etaExpandToJoinPointRule Int join_arity rule :: CoreRule rule@(Rule { ru_bndrs :: CoreRule -> [TyVar] ru_bndrs = [TyVar] bndrs, ru_rhs :: CoreRule -> CoreExpr ru_rhs = CoreExpr rhs , ru_args :: CoreRule -> [CoreExpr] ru_args = [CoreExpr] args }) | Int need_args Int -> Int -> Bool forall a. Eq a => a -> a -> Bool == Int 0 = CoreRule rule | Int need_args Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = String -> SDoc -> CoreRule forall a. HasCallStack => String -> SDoc -> a pprPanic String "etaExpandToJoinPointRule" (Int -> SDoc forall a. Outputable a => a -> SDoc ppr Int join_arity SDoc -> SDoc -> SDoc forall doc. IsDoc doc => doc -> doc -> doc $$ CoreRule -> SDoc forall a. Outputable a => a -> SDoc ppr CoreRule rule) | Bool otherwise = CoreRule rule { ru_bndrs = bndrs ++ new_bndrs , ru_args = args ++ new_args , ru_rhs = new_rhs } -- new_rhs really ought to be occ-analysed (see GHC.Core Note -- [OccInfo in unfoldings and rules]), but it makes a module loop to -- do so; it doesn't happen often; and it doesn't really matter if -- the outer binders have bogus occurrence info; and new_rhs won't -- have dead code if rhs didn't. where need_args :: Int need_args = Int join_arity Int -> Int -> Int forall a. Num a => a -> a -> a - [CoreExpr] -> Int forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [CoreExpr] args ([TyVar] new_bndrs, CoreExpr new_rhs) = Int -> CoreExpr -> ([TyVar], CoreExpr) etaBodyForJoinPoint Int need_args CoreExpr rhs new_args :: [CoreExpr] new_args = [TyVar] -> [CoreExpr] forall b. [TyVar] -> [Expr b] varsToCoreExprs [TyVar] new_bndrs -- Adds as many binders as asked for; assumes expr is not a lambda etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr) etaBodyForJoinPoint :: Int -> CoreExpr -> ([TyVar], CoreExpr) etaBodyForJoinPoint Int need_args CoreExpr body = Int -> Type -> Subst -> [TyVar] -> CoreExpr -> ([TyVar], CoreExpr) go Int need_args Type body_ty (InScopeSet -> Subst mkEmptySubst InScopeSet in_scope) [] CoreExpr body where go :: Int -> Type -> Subst -> [TyVar] -> CoreExpr -> ([TyVar], CoreExpr) go Int 0 Type _ Subst _ [TyVar] rev_bs CoreExpr e = ([TyVar] -> [TyVar] forall a. [a] -> [a] reverse [TyVar] rev_bs, CoreExpr e) go Int n Type ty Subst subst [TyVar] rev_bs CoreExpr e | Just (TyVar tv, Type res_ty) <- Type -> Maybe (TyVar, Type) splitForAllTyCoVar_maybe Type ty , let (Subst subst', TyVar tv') = HasDebugCallStack => Subst -> TyVar -> (Subst, TyVar) Subst -> TyVar -> (Subst, TyVar) substVarBndr Subst subst TyVar tv = Int -> Type -> Subst -> [TyVar] -> CoreExpr -> ([TyVar], CoreExpr) go (Int nInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) Type res_ty Subst subst' (TyVar tv' TyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] : [TyVar] rev_bs) (CoreExpr e CoreExpr -> CoreExpr -> CoreExpr forall b. Expr b -> Expr b -> Expr b `App` TyVar -> CoreExpr forall b. TyVar -> Expr b varToCoreExpr TyVar tv') -- The varToCoreExpr is important: `tv` might be a coercion variable | Just (FunTyFlag _, Type mult, Type arg_ty, Type res_ty) <- Type -> Maybe (FunTyFlag, Type, Type, Type) splitFunTy_maybe Type ty , let (Subst subst', TyVar b) = Int -> Subst -> Scaled Type -> (Subst, TyVar) freshEtaId Int n Subst subst (Type -> Type -> Scaled Type forall a. Type -> a -> Scaled a Scaled Type mult Type arg_ty) = Int -> Type -> Subst -> [TyVar] -> CoreExpr -> ([TyVar], CoreExpr) go (Int nInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) Type res_ty Subst subst' (TyVar b TyVar -> [TyVar] -> [TyVar] forall a. a -> [a] -> [a] : [TyVar] rev_bs) (CoreExpr e CoreExpr -> CoreExpr -> CoreExpr forall b. Expr b -> Expr b -> Expr b `App` TyVar -> CoreExpr forall b. TyVar -> Expr b varToCoreExpr TyVar b) -- The varToCoreExpr is important: `b` might be a coercion variable | Bool otherwise = String -> SDoc -> ([TyVar], CoreExpr) forall a. HasCallStack => String -> SDoc -> a pprPanic String "etaBodyForJoinPoint" (SDoc -> ([TyVar], CoreExpr)) -> SDoc -> ([TyVar], CoreExpr) forall a b. (a -> b) -> a -> b $ Int -> SDoc forall doc. IsLine doc => Int -> doc int Int need_args SDoc -> SDoc -> SDoc forall doc. IsDoc doc => doc -> doc -> doc $$ CoreExpr -> SDoc forall a. Outputable a => a -> SDoc ppr CoreExpr body SDoc -> SDoc -> SDoc forall doc. IsDoc doc => doc -> doc -> doc $$ Type -> SDoc forall a. Outputable a => a -> SDoc ppr (HasDebugCallStack => CoreExpr -> Type CoreExpr -> Type exprType CoreExpr body) body_ty :: Type body_ty = HasDebugCallStack => CoreExpr -> Type CoreExpr -> Type exprType CoreExpr body in_scope :: InScopeSet in_scope = VarSet -> InScopeSet mkInScopeSet (CoreExpr -> VarSet exprFreeVars CoreExpr body VarSet -> VarSet -> VarSet `unionVarSet` Type -> VarSet tyCoVarsOfType Type body_ty) -- in_scope is a bit tricky. -- - We are wrapping `body` in some value lambdas, so must not shadow -- any free vars of `body` -- - We are wrapping `body` in some type lambdas, so must not shadow any -- tyvars in body_ty. Example: body is just a variable -- (g :: forall (a::k). T k a -> Int) -- We must not shadown that `k` when adding the /\a. So treat the free vars -- of body_ty as in-scope. Showed up in #23026. -------------- freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, Id) -- Make a fresh Id, with specified type (after applying substitution) -- It should be "fresh" in the sense that it's not in the in-scope set -- of the TvSubstEnv; and it should itself then be added to the in-scope -- set of the TvSubstEnv -- -- The Int is just a reasonable starting point for generating a unique; -- it does not necessarily have to be unique itself. freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, TyVar) freshEtaId Int n Subst subst Scaled Type ty = (Subst subst', TyVar eta_id') where Scaled Type mult' Type ty' = HasDebugCallStack => Subst -> Scaled Type -> Scaled Type Subst -> Scaled Type -> Scaled Type Type.substScaledTyUnchecked Subst subst Scaled Type ty eta_id' :: TyVar eta_id' = InScopeSet -> TyVar -> TyVar uniqAway (Subst -> InScopeSet getSubstInScope Subst subst) (TyVar -> TyVar) -> TyVar -> TyVar forall a b. (a -> b) -> a -> b $ FastString -> Unique -> Type -> Type -> TyVar mkSysLocalOrCoVar (String -> FastString fsLit String "eta") (Int -> Unique mkBuiltinUnique Int n) Type mult' Type ty' -- "OrCoVar" since this can be used to eta-expand -- coercion abstractions subst' :: Subst subst' = Subst -> TyVar -> Subst extendSubstInScope Subst subst TyVar eta_id'