diff options
Diffstat (limited to 'compiler/GHC/Core')
| -rw-r--r-- | compiler/GHC/Core/Arity.hs | 1211 | ||||
| -rw-r--r-- | compiler/GHC/Core/FVs.hs | 777 | ||||
| -rw-r--r-- | compiler/GHC/Core/Lint.hs | 2821 | ||||
| -rw-r--r-- | compiler/GHC/Core/Make.hs | 940 | ||||
| -rw-r--r-- | compiler/GHC/Core/Map.hs | 803 | ||||
| -rw-r--r-- | compiler/GHC/Core/Op/Tidy.hs | 286 | ||||
| -rw-r--r-- | compiler/GHC/Core/Ppr.hs | 657 | ||||
| -rw-r--r-- | compiler/GHC/Core/Ppr/TyThing.hs | 205 | ||||
| -rw-r--r-- | compiler/GHC/Core/Rules.hs | 1254 | ||||
| -rw-r--r-- | compiler/GHC/Core/Seq.hs | 115 | ||||
| -rw-r--r-- | compiler/GHC/Core/SimpleOpt.hs | 1475 | ||||
| -rw-r--r-- | compiler/GHC/Core/Stats.hs | 137 | ||||
| -rw-r--r-- | compiler/GHC/Core/Subst.hs | 758 | ||||
| -rw-r--r-- | compiler/GHC/Core/Unfold.hs | 1642 | ||||
| -rw-r--r-- | compiler/GHC/Core/Unfold.hs-boot | 16 | ||||
| -rw-r--r-- | compiler/GHC/Core/Utils.hs | 2567 |
16 files changed, 15664 insertions, 0 deletions
diff --git a/compiler/GHC/Core/Arity.hs b/compiler/GHC/Core/Arity.hs new file mode 100644 index 0000000000..73122bef30 --- /dev/null +++ b/compiler/GHC/Core/Arity.hs @@ -0,0 +1,1211 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + + Arity and eta expansion +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Arity and eta expansion +module GHC.Core.Arity + ( manifestArity, joinRhsArity, exprArity, typeArity + , exprEtaExpandArity, findRhsArity, etaExpand + , etaExpandToJoinPoint, etaExpandToJoinPointRule + , exprBotStrictness_maybe + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Subst +import Demand +import Var +import VarEnv +import Id +import Type +import TyCon ( initRecTc, checkRecTc ) +import Predicate ( isDictTy ) +import Coercion +import BasicTypes +import Unique +import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt ) +import Outputable +import FastString +import Util ( debugIsOn ) + +{- +************************************************************************ +* * + 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 (Lam v e) | isId v = 1 + manifestArity e + | otherwise = manifestArity e +manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e +manifestArity (Cast e _) = manifestArity e +manifestArity _ = 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 +joinRhsArity (Lam _ e) = 1 + joinRhsArity e +joinRhsArity _ = 0 + + +--------------- +exprArity :: CoreExpr -> Arity +-- ^ An approximate, fast, version of 'exprEtaExpandArity' +exprArity e = go e + where + go (Var v) = idArity v + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Tick t e) | not (tickishIsCode t) = go e + go (Cast e co) = trim_arity (go e) (coercionRKind co) + -- Note [exprArity invariant] + go (App e (Type _)) = go e + go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 + -- See Note [exprArity for applications] + -- NB: coercions count as a value argument + + go _ = 0 + + trim_arity :: Arity -> Type -> Arity + trim_arity arity ty = arity `min` length (typeArity ty) + +--------------- +typeArity :: Type -> [OneShotInfo] +-- How many value arrows are visible in the type? +-- We look through foralls, and newtypes +-- See Note [exprArity invariant] +typeArity ty + = go initRecTc ty + where + go rec_nts ty + | Just (_, ty') <- splitForAllTy_maybe ty + = go rec_nts ty' + + | Just (arg,res) <- splitFunTy_maybe ty + = typeOneShot arg : go rec_nts res + + | Just (tc,tys) <- splitTyConApp_maybe ty + , Just (ty', _) <- instNewTyCon_maybe tc tys + , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] + -- in TyCon +-- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes +-- -- See Note [Newtype classes and eta expansion] +-- (no longer required) + = go rec_nts' 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))) + + | otherwise + = [] + +--------------- +exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig) +-- A cheap and cheerful function that identifies bottoming functions +-- and gives them a suitable strictness signatures. It's used during +-- float-out +exprBotStrictness_maybe e + = case getBotArity (arityType env e) of + Nothing -> Nothing + Just ar -> Just (ar, sig ar) + where + env = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False } + sig ar = mkClosedStrictSig (replicate ar topDmd) botDiv + +{- +Note [exprArity invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprArity has the following invariants: + + (1) If typeArity (exprType e) = n, + then manifestArity (etaExpand e n) = n + + That is, etaExpand can always expand as much as typeArity says + So the case analysis in etaExpand and in typeArity must match + + (2) exprArity e <= typeArity (exprType e) + + (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n + + That is, if exprArity says "the arity is n" then etaExpand really + can get "n" manifest lambdas to the top. + +Why is this important? Because + - In GHC.Iface.Tidy we use exprArity to fix the *final arity* of + each top-level Id, and in + - In CorePrep we use etaExpand on each rhs, so that the visible lambdas + actually match that arity, which in turn means + that the StgRhs has the right number of lambdas + +An alternative would be to do the eta-expansion in GHC.Iface.Tidy, at least +for top-level bindings, in which case we would not need the trim_arity +in exprArity. That is a less local change, so I'm going to leave it for today! + +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 TcInstDcls. 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 ----------- + + +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 + + +************************************************************************ +* * + 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A Big Deal with computing arities is expressions like + + 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 is + f = \x -> case x of + True -> error "foo" + False -> \y -> x+y +then we want to get arity 2. Technically, this isn't quite right, because + (f True) `seq` 1 +should diverge, but it'll converge if we eta-expand f. Nevertheless, we +do so; it improves some programs significantly, and increasing convergence +isn't a bad thing. Hence the ABot/ATop in ArityType. + +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 if all the branches of + the case are known to return bottom. + case x of { (a,b) -> \y -> error "urk" } + This case is less important, but the idea is that if the fn is + going to diverge eventually anyway then getting the best arity + isn't an issue, so we might as well play safe + + (3) 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. + +4. Note [Newtype arity] +~~~~~~~~~~~~~~~~~~~~~~~~ +Non-recursive newtypes are transparent, and should not get in the way. +We do (currently) eta-expand recursive newtypes too. So if we have, say + + newtype T = MkT ([T] -> Int) + +Suppose we have + e = coerce T f +where f has arity 1. Then: etaExpandArity e = 1; +that is, etaExpandArity looks through the coerce. + +When we eta-expand e to arity 1: eta_expand 1 e T +we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + + HOWEVER, note that if you use coerce bogusly you can ge + coerce Int negate + And since negate has arity 2, you might try to eta expand. But you can't + 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 bottomming 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 is the result of a compositional analysis on expressions, +from which we can decide the real arity of the expression (extracted +with function exprEtaExpandArity). + +Here is what the fields mean. If an arbitrary expression 'f' has +ArityType 'at', then + + * If at = ABot n, then (f x1..xn) definitely diverges. Partial + applications to fewer than n args may *or may not* diverge. + + We allow ourselves to eta-expand bottoming functions, even + if doing so may lose some `seq` sharing, + let x = <expensive> in \y. error (g x y) + ==> \y. let x = <expensive> in error (g x y) + + * If at = ATop as, and n=length as, + then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing, + assuming the calls of f respect the one-shot-ness of + its definition. + + NB 'f' is an arbitrary expression, eg (f = g e1 e2). This 'f' + can have ArityType as ATop, with length as > 0, only if e1 e2 are + themselves. + + * In both cases, f, (f x1), ... (f x1 ... f(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# + +Example: + f = \x\y. let v = <expensive> in + \s(one-shot) \t(one-shot). blah + 'f' has ArityType [ManyShot,ManyShot,OneShot,OneShot] + The one-shot-ness means we can, in effect, push that + 'let' inside the \st. + + +Suppose f = \xy. x+y +Then f :: AT [False,False] ATop + f v :: AT [False] ATop + f <expensive> :: AT [] ATop + +-------------------- Main arity code ---------------------------- +-} + +-- See Note [ArityType] +data ArityType = ATop [OneShotInfo] | ABot Arity + -- There is always an explicit lambda + -- to justify the [OneShot], or the Arity + +instance Outputable ArityType where + ppr (ATop os) = text "ATop" <> parens (ppr (length os)) + ppr (ABot n) = text "ABot" <> parens (ppr n) + +vanillaArityType :: ArityType +vanillaArityType = ATop [] -- Totally uninformative + +-- ^ The Arity returned is the number of value args the +-- expression can be applied to without doing much work +exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity +-- exprEtaExpandArity is used when eta expanding +-- e ==> \xy -> e x y +exprEtaExpandArity dflags e + = case (arityType env e) of + ATop oss -> length oss + ABot n -> n + where + env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp + , ae_ped_bot = gopt Opt_PedanticBottoms dflags } + +getBotArity :: ArityType -> Maybe Arity +-- Arity of a divergent function +getBotArity (ABot n) = Just n +getBotArity _ = Nothing + +mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun +mk_cheap_fn dflags cheap_app + | not (gopt Opt_DictsCheap dflags) + = \e _ -> exprIsCheapX cheap_app e + | otherwise + = \e mb_ty -> exprIsCheapX cheap_app e + || case mb_ty of + Nothing -> False + Just ty -> isDictTy ty + + +---------------------- +findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> (Arity, Bool) +-- This implements the fixpoint loop for arity analysis +-- See Note [Arity analysis] +-- If findRhsArity e = (n, is_bot) then +-- (a) any application of e to <n arguments will not do much work, +-- so it is safe to expand e ==> (\x1..xn. e x1 .. xn) +-- (b) if is_bot=True, then e applied to n args is guaranteed bottom +findRhsArity dflags bndr rhs old_arity + = go (get_arity init_cheap_app) + -- We always call exprEtaExpandArity once, but usually + -- that produces a result equal to old_arity, and then + -- we stop right away (since arities should not decrease) + -- Result: the common case is that there is just one iteration + where + is_lam = has_lam rhs + + has_lam (Tick _ e) = has_lam e + has_lam (Lam b e) = isId b || has_lam e + has_lam _ = False + + init_cheap_app :: CheapAppFun + init_cheap_app fn n_val_args + | fn == bndr = True -- On the first pass, this binder gets infinite arity + | otherwise = isCheapApp fn n_val_args + + go :: (Arity, Bool) -> (Arity, Bool) + go cur_info@(cur_arity, _) + | cur_arity <= old_arity = cur_info + | new_arity == cur_arity = cur_info + | otherwise = ASSERT( new_arity < cur_arity ) +#if defined(DEBUG) + pprTrace "Exciting arity" + (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity + , ppr rhs]) +#endif + go new_info + where + new_info@(new_arity, _) = get_arity cheap_app + + cheap_app :: CheapAppFun + cheap_app fn n_val_args + | fn == bndr = n_val_args < cur_arity + | otherwise = isCheapApp fn n_val_args + + get_arity :: CheapAppFun -> (Arity, Bool) + get_arity cheap_app + = case (arityType env rhs) of + ABot n -> (n, True) + ATop (os:oss) | isOneShotInfo os || is_lam + -> (1 + length oss, False) -- Don't expand PAPs/thunks + ATop _ -> (0, False) -- Note [Eta expanding thunks] + where + env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app + , ae_ped_bot = gopt Opt_PedanticBottoms dflags } + +{- +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. + +The analysis is easy to achieve because exprEtaExpandArity takes an +argument + type CheapFun = CoreExpr -> Maybe Type -> Bool +used to decide if an expression is cheap enough to push inside a +lambda. And exprIsCheapX in turn takes an argument + type CheapAppFun = Id -> Int -> Bool +which tells when an application is cheap. This makes it easy to +write the analysis loop. + +The analysis is cheap-and-cheerful because it doesn't deal with +mutual recursion. But the self-recursive case is the important one. + + +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. + +Note [Eta expanding thunks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't eta-expand + * Trivial RHSs x = y + * PAPs x = map g + * Thunks f = case y of p -> \x -> blah + +When we see + f = case y of p -> \x -> blah +should we eta-expand it? Well, if 'x' is a one-shot state token +then 'yes' because 'f' will only be applied once. But otherwise +we (conservatively) say no. My main reason is to avoid expanding +PAPSs + f = g d ==> f = \x. g d x +because that might in turn make g inline (if it has an inline pragma), +which we might not want. After all, INLINE pragmas say "inline only +when saturated" so we don't want to be too gung-ho about saturating! +-} + +arityLam :: Id -> ArityType -> ArityType +arityLam id (ATop as) = ATop (idStateHackOneShotInfo id : as) +arityLam _ (ABot n) = ABot (n+1) + +floatIn :: Bool -> ArityType -> ArityType +-- We have something like (let x = E in b), +-- where b has the given arity type. +floatIn _ (ABot n) = ABot n +floatIn True (ATop as) = ATop as +floatIn False (ATop as) = ATop (takeWhile isOneShotInfo as) + -- If E is not cheap, keep arity only for one-shots + +arityApp :: ArityType -> Bool -> ArityType +-- Processing (fun arg) where at is the ArityType of fun, +-- Knock off an argument and behave like 'let' +arityApp (ABot 0) _ = ABot 0 +arityApp (ABot n) _ = ABot (n-1) +arityApp (ATop []) _ = ATop [] +arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as) + +andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case' +andArityType (ABot n1) (ABot n2) = ABot (n1 `max` n2) -- Note [ABot branches: use max] +andArityType (ATop as) (ABot _) = ATop as +andArityType (ABot _) (ATop bs) = ATop bs +andArityType (ATop as) (ATop bs) = ATop (as `combine` bs) + where -- See Note [Combining case branches] + combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs + combine [] bs = takeWhile isOneShotInfo bs + combine as [] = takeWhile isOneShotInfo as + +{- Note [ABot branches: use max] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider case x of + True -> \x. error "urk" + False -> \xy. error "urk2" + +Remember: ABot n means "if you apply to n args, it'll definitely diverge". +So we need (ABot 2) for the whole thing, the /max/ of the ABot arities. + +Note [Combining case branches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + 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 eta-expand go and go2. +When combining the branches of the case we have + ATop [] `andAT` ATop [OneShotLam] +and we want to get ATop [OneShotLam]. But if the inner +lambda wasn't one-shot we don't want to do this. +(We need a proper arity analysis to justify that.) + +So 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. + +Note [Arity trimming] +~~~~~~~~~~~~~~~~~~~~~ +Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and +F is some type family. + +Because of Note [exprArity invariant], item (2), we must return with arity at +most 1, because typeArity (Int -> F a) = 1. So we have to trim the result of +calling arityType on (\x y. blah). Failing to do so, and hence breaking the +exprArity invariant, led to #5441. + +How to trim? For ATop, it's easy. But we must take great care with ABot. +Suppose the expression was (\x y. error "urk"), we'll get (ABot 2). We +absolutely must not trim that to (ABot 1), 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, do not reduce the 'n' in (ABot n); rather, switch (conservatively) to ATop. + +Historical note: long ago, we unconditionally switched to ATop when we +encountered a cast, but that is far too conservative: see #5475 +-} + +--------------------------- +type CheapFun = CoreExpr -> Maybe Type -> Bool + -- How to decide if an expression is cheap + -- If the Maybe is Just, the type is the type + -- of the expression; Nothing means "don't know" + +data ArityEnv + = AE { ae_cheap_fn :: CheapFun + , ae_ped_bot :: Bool -- True <=> be pedantic about bottoms + } + +arityType :: ArityEnv -> CoreExpr -> ArityType + +arityType env (Cast e co) + = case arityType env e of + ATop os -> ATop (take co_arity os) + -- See Note [Arity trimming] + ABot n | co_arity < n -> ATop (replicate co_arity noOneShotInfo) + | otherwise -> ABot n + where + co_arity = length (typeArity (coercionRKind co)) + -- See Note [exprArity invariant] (2); must be true of + -- arityType too, since that is how we compute the arity + -- of variables, and they in turn affect result of exprArity + -- #5441 is a nice demo + -- However, do make sure that ATop -> ATop and ABot -> ABot! + -- Casts don't affect that part. Getting this wrong provoked #5475 + +arityType _ (Var v) + | strict_sig <- idStrictness v + , not $ isTopSig strict_sig + , (ds, res) <- splitStrictSig strict_sig + , let arity = length ds + = if isBotDiv res then ABot arity + else ATop (take arity one_shots) + | otherwise + = ATop (take (idArity v) one_shots) + where + one_shots :: [OneShotInfo] -- One-shot-ness derived from the type + one_shots = typeArity (idType v) + + -- Lambdas; increase arity +arityType env (Lam x e) + | isId x = arityLam x (arityType env e) + | otherwise = arityType env e + + -- Applications; decrease arity, except for types +arityType env (App fun (Type _)) + = arityType env fun +arityType env (App fun arg ) + = arityApp (arityType env fun) (ae_cheap_fn env arg 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 env (Case scrut _ _ alts) + | exprIsBottom scrut || null alts + = ABot 0 -- Do not eta expand + -- See Note [Dealing with bottom (1)] + | otherwise + = case alts_type of + ABot n | n>0 -> ATop [] -- Don't eta expand + | otherwise -> ABot 0 -- if RHS is bottomming + -- See Note [Dealing with bottom (2)] + + ATop as | not (ae_ped_bot env) -- See Note [Dealing with bottom (3)] + , ae_cheap_fn env scrut Nothing -> ATop as + | exprOkForSpeculation scrut -> ATop as + | otherwise -> ATop (takeWhile isOneShotInfo as) + where + alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts] + +arityType env (Let b e) + = floatIn (cheap_bind b) (arityType env e) + where + cheap_bind (NonRec b e) = is_cheap (b,e) + cheap_bind (Rec prs) = all is_cheap prs + is_cheap (b,e) = ae_cheap_fn env e (Just (idType b)) + +arityType env (Tick t e) + | not (tickishIsCode t) = arityType env e + +arityType _ _ = vanillaArityType + +{- +%************************************************************************ +%* * + 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 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. I think +that for the use in CorePrep it really doesn't matter; and if +it does, then CoreToStg.myCollectArgs will fall over. + +(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. + +-} + +-- | @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 -- ^ Result should have this number of value args + -> CoreExpr -- ^ Expression to expand + -> CoreExpr +-- etaExpand arity e = res +-- Then 'res' has at least 'arity' lambdas at the top +-- +-- etaExpand deals with for-alls. For example: +-- etaExpand 1 E +-- where E :: forall a. a -> a +-- would return +-- (/\b. \y::a -> E b y) +-- +-- It deals with coerces too, though they are now rare +-- so perhaps the extra code isn't worth it + +etaExpand n orig_expr + = go n orig_expr + where + -- Strip off existing lambdas and casts before handing off to mkEtaWW + -- Note [Eta expansion and SCCs] + go 0 expr = expr + go n (Lam v body) | isTyVar v = Lam v (go n body) + | otherwise = Lam v (go (n-1) body) + go n (Cast expr co) = Cast (go n expr) co + go n expr + = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $ + retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas) + where + in_scope = mkInScopeSet (exprFreeVars expr) + (in_scope', etas) = mkEtaWW n (ppr orig_expr) in_scope (exprType expr) + subst' = mkEmptySubst in_scope' + + -- Find ticks behind type apps. + -- See Note [Eta expansion and source notes] + (expr', args) = collectArgs expr + (ticks, expr'') = stripTicksTop tickishFloatable expr' + sexpr = foldl' App expr'' args + retick expr = foldr mkTick expr ticks + + -- Abstraction Application +-------------- +data EtaInfo = EtaVar Var -- /\a. [] [] a + -- \x. [] [] x + | EtaCo Coercion -- [] |> sym co [] |> co + +instance Outputable EtaInfo where + ppr (EtaVar v) = text "EtaVar" <+> ppr v + ppr (EtaCo co) = text "EtaCo" <+> ppr co + +pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo] +pushCoercion co1 (EtaCo co2 : eis) + | isReflCo co = eis + | otherwise = EtaCo co : eis + where + co = co1 `mkTransCo` co2 + +pushCoercion co eis = EtaCo co : eis + +-------------- +etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr +etaInfoAbs [] expr = expr +etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr) +etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co) + +-------------- +etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr +-- (etaInfoApp s e eis) returns something equivalent to +-- ((substExpr s e) `appliedto` eis) + +etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) + = etaInfoApp (GHC.Core.Subst.extendSubstWithVar subst v1 v2) e eis + +etaInfoApp subst (Cast e co1) eis + = etaInfoApp subst e (pushCoercion co' eis) + where + co' = GHC.Core.Subst.substCo subst co1 + +etaInfoApp subst (Case e b ty alts) eis + = Case (subst_expr subst e) b1 ty' alts' + where + (subst1, b1) = substBndr subst b + alts' = map subst_alt alts + ty' = etaInfoAppTy (GHC.Core.Subst.substTy subst ty) eis + subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) + where + (subst2,bs') = substBndrs subst1 bs + +etaInfoApp subst (Let b e) eis + | not (isJoinBind b) + -- See Note [Eta expansion for join points] + = Let b' (etaInfoApp subst' e eis) + where + (subst', b') = substBindSC subst b + +etaInfoApp subst (Tick t e) eis + = Tick (substTickish subst t) (etaInfoApp subst e eis) + +etaInfoApp subst expr _ + | (Var fun, _) <- collectArgs expr + , Var fun' <- lookupIdSubst (text "etaInfoApp" <+> ppr fun) subst fun + , isJoinId fun' + = subst_expr subst expr + +etaInfoApp subst e eis + = go (subst_expr subst e) eis + where + go e [] = e + go e (EtaVar v : eis) = go (App e (varToCoreExpr v)) eis + go e (EtaCo co : eis) = go (Cast e co) eis + + +-------------- +etaInfoAppTy :: Type -> [EtaInfo] -> Type +-- If e :: ty +-- then etaInfoApp e eis :: etaInfoApp ty eis +etaInfoAppTy ty [] = ty +etaInfoAppTy ty (EtaVar v : eis) = etaInfoAppTy (applyTypeToArg ty (varToCoreExpr v)) eis +etaInfoAppTy _ (EtaCo co : eis) = etaInfoAppTy (coercionRKind co) eis + +-------------- +-- | @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 + :: Arity + -- ^ 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 orig_n ppr_orig_expr in_scope orig_ty + = go orig_n empty_subst orig_ty [] + where + empty_subst = mkEmptyTCvSubst in_scope + + go :: Arity -- Number of value args to expand to + -> TCvSubst -> Type -- We are really looking at subst(ty) + -> [EtaInfo] -- Accumulating parameter + -> (InScopeSet, [EtaInfo]) + go n subst ty eis -- See Note [exprArity invariant] + + ----------- Done! No more expansion needed + | n == 0 + = (getTCvInScope subst, reverse eis) + + ----------- Forall types (forall a. ty) + | Just (tcv,ty') <- splitForAllTy_maybe ty + , let (subst', tcv') = Type.substVarBndr subst tcv + = let ((n_subst, n_tcv), n_n) + -- We want to have at least 'n' lambdas at the top. + -- If tcv is a tyvar, it corresponds to one Lambda (/\). + -- And we won't reduce n. + -- If tcv is a covar, we could eta-expand the expr with one + -- lambda \co:ty. e co. In this case we generate a new variable + -- of the coercion type, update the scope, and reduce n by 1. + | isTyVar tcv = ((subst', tcv'), n) + | otherwise = (freshEtaId n subst' (varType tcv'), n-1) + -- Avoid free vars of the original expression + in go n_n n_subst ty' (EtaVar n_tcv : eis) + + ----------- Function types (t1 -> t2) + | Just (arg_ty, res_ty) <- splitFunTy_maybe ty + , not (isTypeLevPoly arg_ty) + -- See Note [Levity polymorphism invariants] in GHC.Core + -- See also test case typecheck/should_run/EtaExpandLevPoly + + , let (subst', eta_id') = freshEtaId n subst arg_ty + -- Avoid free vars of the original expression + = go (n-1) subst' res_ty (EtaVar eta_id' : eis) + + ----------- 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 (co, ty') <- topNormaliseNewType_maybe ty + , let co' = Coercion.substCo subst 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) + = go n subst ty' (pushCoercion co' eis) + + | otherwise -- We have an expression of arity > 0, + -- but its type isn't a function, or a binder + -- is levity-polymorphic + = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr_orig_expr ) + (getTCvInScope subst, reverse eis) + -- 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 + + + +-------------- +-- Don't use short-cutting substitution - we may be changing the types of join +-- points, so applying the in-scope set is necessary +-- TODO Check if we actually *are* changing any join points' types + +subst_expr :: Subst -> CoreExpr -> CoreExpr +subst_expr = substExpr (text "GHC.Core.Arity:substExpr") + + +-------------- + +-- | 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 join_arity expr + = go join_arity [] expr + where + go 0 rev_bs e = (reverse rev_bs, e) + go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e + go n rev_bs e = case etaBodyForJoinPoint n e of + (bs, e') -> (reverse rev_bs ++ bs, e') + +etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule +etaExpandToJoinPointRule _ rule@(BuiltinRule {}) + = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule])) + -- How did a local binding get a built-in rule anyway? Probably a plugin. + rule +etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs + , ru_args = args }) + | need_args == 0 + = rule + | need_args < 0 + = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule) + | otherwise + = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args + , ru_rhs = new_rhs } + where + need_args = join_arity - length args + (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs + new_args = varsToCoreExprs new_bndrs + +-- Adds as many binders as asked for; assumes expr is not a lambda +etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr) +etaBodyForJoinPoint need_args body + = go need_args (exprType body) (init_subst body) [] body + where + go 0 _ _ rev_bs e + = (reverse rev_bs, e) + go n ty subst rev_bs e + | Just (tv, res_ty) <- splitForAllTy_maybe ty + , let (subst', tv') = Type.substVarBndr subst tv + = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv') + | Just (arg_ty, res_ty) <- splitFunTy_maybe ty + , let (subst', b) = freshEtaId n subst arg_ty + = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b) + | otherwise + = pprPanic "etaBodyForJoinPoint" $ int need_args $$ + ppr body $$ ppr (exprType body) + + init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e)) + +-------------- +freshEtaId :: Int -> TCvSubst -> Type -> (TCvSubst, 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 n subst ty + = (subst', eta_id') + where + ty' = Type.substTyUnchecked subst ty + eta_id' = uniqAway (getTCvInScope subst) $ + mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) ty' + -- "OrCoVar" since this can be used to eta-expand + -- coercion abstractions + subst' = extendTCvInScope subst eta_id' diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs new file mode 100644 index 0000000000..00c2bbfe9f --- /dev/null +++ b/compiler/GHC/Core/FVs.hs @@ -0,0 +1,777 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Taken quite directly from the Peyton Jones/Lester paper. +-} + +{-# LANGUAGE CPP #-} + +-- | A module concerned with finding the free variables of an expression. +module GHC.Core.FVs ( + -- * Free variables of expressions and binding groups + exprFreeVars, + exprFreeVarsDSet, + exprFreeVarsList, + exprFreeIds, + exprFreeIdsDSet, + exprFreeIdsList, + exprsFreeIdsDSet, + exprsFreeIdsList, + exprsFreeVars, + exprsFreeVarsList, + bindFreeVars, + + -- * Selective free variables of expressions + InterestingVarFun, + exprSomeFreeVars, exprsSomeFreeVars, + exprSomeFreeVarsList, exprsSomeFreeVarsList, + + -- * Free variables of Rules, Vars and Ids + varTypeTyCoVars, + varTypeTyCoFVs, + idUnfoldingVars, idFreeVars, dIdFreeVars, + bndrRuleAndUnfoldingVarsDSet, + idFVs, + idRuleVars, idRuleRhsVars, stableUnfoldingVars, + ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, + rulesFreeVarsDSet, + ruleLhsFreeIds, ruleLhsFreeIdsList, + + expr_fvs, + + -- * Orphan names + orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom, + orphNamesOfTypes, orphNamesOfCoCon, + exprsOrphNames, orphNamesOfFamInst, + + -- * Core syntax tree annotation with free variables + FVAnn, -- annotation, abstract + CoreExprWithFVs, -- = AnnExpr Id FVAnn + CoreExprWithFVs', -- = AnnExpr' Id FVAnn + CoreBindWithFVs, -- = AnnBind Id FVAnn + CoreAltWithFVs, -- = AnnAlt Id FVAnn + freeVars, -- CoreExpr -> CoreExprWithFVs + freeVarsBind, -- CoreBind -> DVarSet -> (DVarSet, CoreBindWithFVs) + freeVarsOf, -- CoreExprWithFVs -> DIdSet + freeVarsOfAnn + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core +import Id +import IdInfo +import NameSet +import UniqSet +import Unique (Uniquable (..)) +import Name +import VarSet +import Var +import Type +import TyCoRep +import TyCoFVs +import TyCon +import CoAxiom +import FamInstEnv +import TysPrim( funTyConName ) +import Maybes( orElse ) +import Util +import BasicTypes( Activation ) +import Outputable +import FV + +{- +************************************************************************ +* * +\section{Finding the free variables of an expression} +* * +************************************************************************ + +This function simply finds the free variables of an expression. +So far as type variables are concerned, it only finds tyvars that are + + * free in type arguments, + * free in the type of a binder, + +but not those that are free in the type of variable occurrence. +-} + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a non-deterministic set. +exprFreeVars :: CoreExpr -> VarSet +exprFreeVars = fvVarSet . exprFVs + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a composable FV computation. See Note [FV naming conventions] in FV +-- for why export it. +exprFVs :: CoreExpr -> FV +exprFVs = filterFV isLocalVar . expr_fvs + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a deterministic set. +exprFreeVarsDSet :: CoreExpr -> DVarSet +exprFreeVarsDSet = fvDVarSet . exprFVs + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a deterministically ordered list. +exprFreeVarsList :: CoreExpr -> [Var] +exprFreeVarsList = fvVarList . exprFVs + +-- | Find all locally-defined free Ids in an expression +exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids +exprFreeIds = exprSomeFreeVars isLocalId + +-- | Find all locally-defined free Ids in an expression +-- returning a deterministic set. +exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids +exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId + +-- | Find all locally-defined free Ids in an expression +-- returning a deterministically ordered list. +exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids +exprFreeIdsList = exprSomeFreeVarsList isLocalId + +-- | Find all locally-defined free Ids in several expressions +-- returning a deterministic set. +exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids +exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId + +-- | Find all locally-defined free Ids in several expressions +-- returning a deterministically ordered list. +exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids +exprsFreeIdsList = exprsSomeFreeVarsList isLocalId + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a non-deterministic set. +exprsFreeVars :: [CoreExpr] -> VarSet +exprsFreeVars = fvVarSet . exprsFVs + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a composable FV computation. See Note [FV naming conventions] in FV +-- for why export it. +exprsFVs :: [CoreExpr] -> FV +exprsFVs exprs = mapUnionFV exprFVs exprs + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a deterministically ordered list. +exprsFreeVarsList :: [CoreExpr] -> [Var] +exprsFreeVarsList = fvVarList . exprsFVs + +-- | Find all locally defined free Ids in a binding group +bindFreeVars :: CoreBind -> VarSet +bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r) +bindFreeVars (Rec prs) = fvVarSet $ filterFV isLocalVar $ + addBndrs (map fst prs) + (mapUnionFV rhs_fvs prs) + +-- | Finds free variables in an expression selected by a predicate +exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> VarSet +exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e + +-- | Finds free variables in an expression selected by a predicate +-- returning a deterministically ordered list. +exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> [Var] +exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e + +-- | Finds free variables in an expression selected by a predicate +-- returning a deterministic set. +exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> DVarSet +exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e + +-- | Finds free variables in several expressions selected by a predicate +exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting + -> [CoreExpr] + -> VarSet +exprsSomeFreeVars fv_cand es = + fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es + +-- | Finds free variables in several expressions selected by a predicate +-- returning a deterministically ordered list. +exprsSomeFreeVarsList :: InterestingVarFun -- Says which 'Var's are interesting + -> [CoreExpr] + -> [Var] +exprsSomeFreeVarsList fv_cand es = + fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es + +-- | Finds free variables in several expressions selected by a predicate +-- returning a deterministic set. +exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> [CoreExpr] + -> DVarSet +exprsSomeFreeVarsDSet fv_cand e = + fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e + +-- Comment about obsolete code +-- We used to gather the free variables the RULES at a variable occurrence +-- with the following cryptic comment: +-- "At a variable occurrence, add in any free variables of its rule rhss +-- Curiously, we gather the Id's free *type* variables from its binding +-- site, but its free *rule-rhs* variables from its usage sites. This +-- is a little weird. The reason is that the former is more efficient, +-- but the latter is more fine grained, and a makes a difference when +-- a variable mentions itself one of its own rule RHSs" +-- Not only is this "weird", but it's also pretty bad because it can make +-- a function seem more recursive than it is. Suppose +-- f = ...g... +-- g = ... +-- RULE g x = ...f... +-- Then f is not mentioned in its own RHS, and needn't be a loop breaker +-- (though g may be). But if we collect the rule fvs from g's occurrence, +-- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB +-- code in GHC.Enum.) +-- +-- Anyway, it seems plain wrong. The RULE is like an extra RHS for the +-- function, so its free variables belong at the definition site. +-- +-- Deleted code looked like +-- foldVarSet add_rule_var var_itself_set (idRuleVars var) +-- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var +-- | otherwise = set +-- SLPJ Feb06 + +addBndr :: CoreBndr -> FV -> FV +addBndr bndr fv fv_cand in_scope acc + = (varTypeTyCoFVs bndr `unionFV` + -- Include type variables in the binder's type + -- (not just Ids; coercion variables too!) + FV.delFV bndr fv) fv_cand in_scope acc + +addBndrs :: [CoreBndr] -> FV -> FV +addBndrs bndrs fv = foldr addBndr fv bndrs + +expr_fvs :: CoreExpr -> FV +expr_fvs (Type ty) fv_cand in_scope acc = + tyCoFVsOfType ty fv_cand in_scope acc +expr_fvs (Coercion co) fv_cand in_scope acc = + tyCoFVsOfCo co fv_cand in_scope acc +expr_fvs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc +expr_fvs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc +expr_fvs (Tick t expr) fv_cand in_scope acc = + (tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc +expr_fvs (App fun arg) fv_cand in_scope acc = + (expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc +expr_fvs (Lam bndr body) fv_cand in_scope acc = + addBndr bndr (expr_fvs body) fv_cand in_scope acc +expr_fvs (Cast expr co) fv_cand in_scope acc = + (expr_fvs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc + +expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc + = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr + (mapUnionFV alt_fvs alts)) fv_cand in_scope acc + where + alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) + +expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc + = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body)) + fv_cand in_scope acc + +expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc + = addBndrs (map fst pairs) + (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body) + fv_cand in_scope acc + +--------- +rhs_fvs :: (Id, CoreExpr) -> FV +rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV` + bndrRuleAndUnfoldingFVs bndr + -- Treat any RULES as extra RHSs of the binding + +--------- +exprs_fvs :: [CoreExpr] -> FV +exprs_fvs exprs = mapUnionFV expr_fvs exprs + +tickish_fvs :: Tickish Id -> FV +tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids +tickish_fvs _ = emptyFV + +{- +************************************************************************ +* * +\section{Free names} +* * +************************************************************************ +-} + +-- | Finds the free /external/ names of an expression, notably +-- including the names of type constructors (which of course do not show +-- up in 'exprFreeVars'). +exprOrphNames :: CoreExpr -> NameSet +-- There's no need to delete local binders, because they will all +-- be /internal/ names. +exprOrphNames e + = go e + where + go (Var v) + | isExternalName n = unitNameSet n + | otherwise = emptyNameSet + where n = idName v + go (Lit _) = emptyNameSet + go (Type ty) = orphNamesOfType ty -- Don't need free tyvars + go (Coercion co) = orphNamesOfCo co + go (App e1 e2) = go e1 `unionNameSet` go e2 + go (Lam v e) = go e `delFromNameSet` idName v + go (Tick _ e) = go e + go (Cast e co) = go e `unionNameSet` orphNamesOfCo co + go (Let (NonRec _ r) e) = go e `unionNameSet` go r + go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSet` go e + go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty + `unionNameSet` unionNameSets (map go_alt as) + + go_alt (_,_,r) = go r + +-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details +exprsOrphNames :: [CoreExpr] -> NameSet +exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es + + +{- ********************************************************************** +%* * + orphNamesXXX + +%* * +%********************************************************************* -} + +orphNamesOfTyCon :: TyCon -> NameSet +orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of + Nothing -> emptyNameSet + Just cls -> unitNameSet (getName cls) + +orphNamesOfType :: Type -> NameSet +orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty' + -- Look through type synonyms (#4912) +orphNamesOfType (TyVarTy _) = emptyNameSet +orphNamesOfType (LitTy {}) = emptyNameSet +orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon + `unionNameSet` orphNamesOfTypes tys +orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) + `unionNameSet` orphNamesOfType res +orphNamesOfType (FunTy _ arg res) = unitNameSet funTyConName -- NB! See #8535 + `unionNameSet` orphNamesOfType arg + `unionNameSet` orphNamesOfType res +orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg +orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co +orphNamesOfType (CoercionTy co) = orphNamesOfCo co + +orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet +orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet + +orphNamesOfTypes :: [Type] -> NameSet +orphNamesOfTypes = orphNamesOfThings orphNamesOfType + +orphNamesOfMCo :: MCoercion -> NameSet +orphNamesOfMCo MRefl = emptyNameSet +orphNamesOfMCo (MCo co) = orphNamesOfCo co + +orphNamesOfCo :: Coercion -> NameSet +orphNamesOfCo (Refl ty) = orphNamesOfType ty +orphNamesOfCo (GRefl _ ty mco) = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco +orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos +orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (ForAllCo _ kind_co co) + = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co +orphNamesOfCo (FunCo _ co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (CoVarCo _) = emptyNameSet +orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos +orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2 +orphNamesOfCo (SymCo co) = orphNamesOfCo co +orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (NthCo _ _ co) = orphNamesOfCo co +orphNamesOfCo (LRCo _ co) = orphNamesOfCo co +orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg +orphNamesOfCo (KindCo co) = orphNamesOfCo co +orphNamesOfCo (SubCo co) = orphNamesOfCo co +orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs +orphNamesOfCo (HoleCo _) = emptyNameSet + +orphNamesOfProv :: UnivCoProvenance -> NameSet +orphNamesOfProv (PhantomProv co) = orphNamesOfCo co +orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co +orphNamesOfProv (PluginProv _) = emptyNameSet + +orphNamesOfCos :: [Coercion] -> NameSet +orphNamesOfCos = orphNamesOfThings orphNamesOfCo + +orphNamesOfCoCon :: CoAxiom br -> NameSet +orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) + = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches + +orphNamesOfAxiom :: CoAxiom br -> NameSet +orphNamesOfAxiom axiom + = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom) + `extendNameSet` getName (coAxiomTyCon axiom) + +orphNamesOfCoAxBranches :: Branches br -> NameSet +orphNamesOfCoAxBranches + = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches + +orphNamesOfCoAxBranch :: CoAxBranch -> NameSet +orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) + = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs + +-- | orphNamesOfAxiom collects the names of the concrete types and +-- type constructors that make up the LHS of a type family instance, +-- including the family name itself. +-- +-- For instance, given `type family Foo a b`: +-- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H] +-- +-- Used in the implementation of ":info" in GHCi. +orphNamesOfFamInst :: FamInst -> NameSet +orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst) + +{- +************************************************************************ +* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +* * +************************************************************************ +-} + +-- | Those variables free in the right hand side of a rule returned as a +-- non-deterministic set +ruleRhsFreeVars :: CoreRule -> VarSet +ruleRhsFreeVars (BuiltinRule {}) = noFVs +ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) + = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs) + -- See Note [Rule free var hack] + +-- | Those variables free in the both the left right hand sides of a rule +-- returned as a non-deterministic set +ruleFreeVars :: CoreRule -> VarSet +ruleFreeVars = fvVarSet . ruleFVs + +-- | Those variables free in the both the left right hand sides of a rule +-- returned as FV computation +ruleFVs :: CoreRule -> FV +ruleFVs (BuiltinRule {}) = emptyFV +ruleFVs (Rule { ru_fn = _do_not_include + -- See Note [Rule free var hack] + , ru_bndrs = bndrs + , ru_rhs = rhs, ru_args = args }) + = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args)) + +-- | Those variables free in the both the left right hand sides of rules +-- returned as FV computation +rulesFVs :: [CoreRule] -> FV +rulesFVs = mapUnionFV ruleFVs + +-- | Those variables free in the both the left right hand sides of rules +-- returned as a deterministic set +rulesFreeVarsDSet :: [CoreRule] -> DVarSet +rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules + +idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet +-- Just the variables free on the *rhs* of a rule +idRuleRhsVars is_active id + = mapUnionVarSet get_fvs (idCoreRules id) + where + get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs + , ru_rhs = rhs, ru_act = act }) + | is_active act + -- See Note [Finding rule RHS free vars] in OccAnal.hs + = delOneFromUniqSet_Directly fvs (getUnique fn) + -- Note [Rule free var hack] + where + fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs) + get_fvs _ = noFVs + +-- | Those variables free in the right hand side of several rules +rulesFreeVars :: [CoreRule] -> VarSet +rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules + +ruleLhsFreeIds :: CoreRule -> VarSet +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +-- and returns them as a non-deterministic set +ruleLhsFreeIds = fvVarSet . ruleLhsFVIds + +ruleLhsFreeIdsList :: CoreRule -> [Var] +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +-- and returns them as a deterministically ordered list +ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds + +ruleLhsFVIds :: CoreRule -> FV +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +-- and returns an FV computation +ruleLhsFVIds (BuiltinRule {}) = emptyFV +ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args }) + = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args) + +{- +Note [Rule free var hack] (Not a hack any more) +~~~~~~~~~~~~~~~~~~~~~~~~~ +We used not to include the Id in its own rhs free-var set. +Otherwise the occurrence analyser makes bindings recursive: + f x y = x+y + RULE: f (f x y) z ==> f x (f y z) +However, the occurrence analyser distinguishes "non-rule loop breakers" +from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will +put this 'f' in a Rec block, but will mark the binding as a non-rule loop +breaker, which is perfectly inlinable. +-} + +{- +************************************************************************ +* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +* * +************************************************************************ + +The free variable pass annotates every node in the expression with its +NON-GLOBAL free variables and type variables. +-} + +type FVAnn = DVarSet -- See Note [The FVAnn invariant] + +{- Note [The FVAnn invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant: a FVAnn, say S, is closed: + That is: if v is in S, + then freevars( v's type/kind ) is also in S +-} + +-- | Every node in a binding group annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +type CoreBindWithFVs = AnnBind Id FVAnn + +-- | Every node in an expression annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +-- NB: see Note [The FVAnn invariant] +type CoreExprWithFVs = AnnExpr Id FVAnn +type CoreExprWithFVs' = AnnExpr' Id FVAnn + +-- | Every node in an expression annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +type CoreAltWithFVs = AnnAlt Id FVAnn + +freeVarsOf :: CoreExprWithFVs -> DIdSet +-- ^ Inverse function to 'freeVars' +freeVarsOf (fvs, _) = fvs + +-- | Extract the vars reported in a FVAnn +freeVarsOfAnn :: FVAnn -> DIdSet +freeVarsOfAnn fvs = fvs + +noFVs :: VarSet +noFVs = emptyVarSet + +aFreeVar :: Var -> DVarSet +aFreeVar = unitDVarSet + +unionFVs :: DVarSet -> DVarSet -> DVarSet +unionFVs = unionDVarSet + +unionFVss :: [DVarSet] -> DVarSet +unionFVss = unionDVarSets + +delBindersFV :: [Var] -> DVarSet -> DVarSet +delBindersFV bs fvs = foldr delBinderFV fvs bs + +delBinderFV :: Var -> DVarSet -> DVarSet +-- This way round, so we can do it multiple times using foldr + +-- (b `delBinderFV` s) +-- * removes the binder b from the free variable set s, +-- * AND *adds* to s the free variables of b's type +-- +-- This is really important for some lambdas: +-- In (\x::a -> x) the only mention of "a" is in the binder. +-- +-- Also in +-- let x::a = b in ... +-- we should really note that "a" is free in this expression. +-- It'll be pinned inside the /\a by the binding for b, but +-- it seems cleaner to make sure that a is in the free-var set +-- when it is mentioned. +-- +-- This also shows up in recursive bindings. Consider: +-- /\a -> letrec x::a = x in E +-- Now, there are no explicit free type variables in the RHS of x, +-- but nevertheless "a" is free in its definition. So we add in +-- the free tyvars of the types of the binders, and include these in the +-- free vars of the group, attached to the top level of each RHS. +-- +-- This actually happened in the defn of errorIO in IOBase.hs: +-- errorIO (ST io) = case (errorIO# io) of +-- _ -> bottom +-- where +-- bottom = bottom -- Never evaluated + +delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b + -- Include coercion variables too! + +varTypeTyCoVars :: Var -> TyCoVarSet +-- Find the type/kind variables free in the type of the id/tyvar +varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var + +dVarTypeTyCoVars :: Var -> DTyCoVarSet +-- Find the type/kind/coercion variables free in the type of the id/tyvar +dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var + +varTypeTyCoFVs :: Var -> FV +varTypeTyCoFVs var = tyCoFVsOfType (varType var) + +idFreeVars :: Id -> VarSet +idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id + +dIdFreeVars :: Id -> DVarSet +dIdFreeVars id = fvDVarSet $ idFVs id + +idFVs :: Id -> FV +-- Type variables, rule variables, and inline variables +idFVs id = ASSERT( isId id) + varTypeTyCoFVs id `unionFV` + bndrRuleAndUnfoldingFVs id + +bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet +bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id + +bndrRuleAndUnfoldingFVs :: Id -> FV +bndrRuleAndUnfoldingFVs id + | isId id = idRuleFVs id `unionFV` idUnfoldingFVs id + | otherwise = emptyFV + +idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars +idRuleVars id = fvVarSet $ idRuleFVs id + +idRuleFVs :: Id -> FV +idRuleFVs id = ASSERT( isId id) + FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id)) + +idUnfoldingVars :: Id -> VarSet +-- Produce free vars for an unfolding, but NOT for an ordinary +-- (non-inline) unfolding, since it is a dup of the rhs +-- and we'll get exponential behaviour if we look at both unf and rhs! +-- But do look at the *real* unfolding, even for loop breakers, else +-- we might get out-of-scope variables +idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id + +idUnfoldingFVs :: Id -> FV +idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV + +stableUnfoldingVars :: Unfolding -> Maybe VarSet +stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf + +stableUnfoldingFVs :: Unfolding -> Maybe FV +stableUnfoldingFVs unf + = case unf of + CoreUnfolding { uf_tmpl = rhs, uf_src = src } + | isStableSource src + -> Just (filterFV isLocalVar $ expr_fvs rhs) + DFunUnfolding { df_bndrs = bndrs, df_args = args } + -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args) + -- DFuns are top level, so no fvs from types of bndrs + _other -> Nothing + + +{- +************************************************************************ +* * +\subsection{Free variables (and types)} +* * +************************************************************************ +-} + +freeVarsBind :: CoreBind + -> DVarSet -- Free vars of scope of binding + -> (CoreBindWithFVs, DVarSet) -- Return free vars of binding + scope +freeVarsBind (NonRec binder rhs) body_fvs + = ( AnnNonRec binder rhs2 + , freeVarsOf rhs2 `unionFVs` body_fvs2 + `unionFVs` bndrRuleAndUnfoldingVarsDSet binder ) + where + rhs2 = freeVars rhs + body_fvs2 = binder `delBinderFV` body_fvs + +freeVarsBind (Rec binds) body_fvs + = ( AnnRec (binders `zip` rhss2) + , delBindersFV binders all_fvs ) + where + (binders, rhss) = unzip binds + rhss2 = map freeVars rhss + rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 + binders_fvs = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders + -- See Note [The FVAnn invariant] + all_fvs = rhs_body_fvs `unionFVs` binders_fvs + -- The "delBinderFV" happens after adding the idSpecVars, + -- since the latter may add some of the binders as fvs + +freeVars :: CoreExpr -> CoreExprWithFVs +-- ^ Annotate a 'CoreExpr' with its (non-global) free type +-- and value variables at every tree node. +freeVars = go + where + go :: CoreExpr -> CoreExprWithFVs + go (Var v) + | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, AnnVar v) + | otherwise = (emptyDVarSet, AnnVar v) + where + ty_fvs = dVarTypeTyCoVars v + -- See Note [The FVAnn invariant] + + go (Lit lit) = (emptyDVarSet, AnnLit lit) + go (Lam b body) + = ( b_fvs `unionFVs` (b `delBinderFV` body_fvs) + , AnnLam b body' ) + where + body'@(body_fvs, _) = go body + b_ty = idType b + b_fvs = tyCoVarsOfTypeDSet b_ty + -- See Note [The FVAnn invariant] + + go (App fun arg) + = ( freeVarsOf fun' `unionFVs` freeVarsOf arg' + , AnnApp fun' arg' ) + where + fun' = go fun + arg' = go arg + + go (Case scrut bndr ty alts) + = ( (bndr `delBinderFV` alts_fvs) + `unionFVs` freeVarsOf scrut2 + `unionFVs` tyCoVarsOfTypeDSet ty + -- Don't need to look at (idType bndr) + -- because that's redundant with scrut + , AnnCase scrut2 bndr ty alts2 ) + where + scrut2 = go scrut + + (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts + alts_fvs = unionFVss alts_fvs_s + + fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), + (con, args, rhs2)) + where + rhs2 = go rhs + + go (Let bind body) + = (bind_fvs, AnnLet bind2 body2) + where + (bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2) + body2 = go body + + go (Cast expr co) + = ( freeVarsOf expr2 `unionFVs` cfvs + , AnnCast expr2 (cfvs, co) ) + where + expr2 = go expr + cfvs = tyCoVarsOfCoDSet co + + go (Tick tickish expr) + = ( tickishFVs tickish `unionFVs` freeVarsOf expr2 + , AnnTick tickish expr2 ) + where + expr2 = go expr + tickishFVs (Breakpoint _ ids) = mkDVarSet ids + tickishFVs _ = emptyDVarSet + + go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) + go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs new file mode 100644 index 0000000000..dc4119dea8 --- /dev/null +++ b/compiler/GHC/Core/Lint.hs @@ -0,0 +1,2821 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +A ``lint'' pass to check for Core correctness. +See Note [Core Lint guarantee]. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Core.Lint ( + lintCoreBindings, lintUnfolding, + lintPassResult, lintInteractiveExpr, lintExpr, + lintAnnots, lintTypes, + + -- ** Debug output + endPass, endPassIO, + dumpPassResult, + GHC.Core.Lint.dumpIfSet, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Stats ( coreBindsStats ) +import CoreMonad +import Bag +import Literal +import DataCon +import TysWiredIn +import TysPrim +import TcType ( isFloatingTy ) +import Var +import VarEnv +import VarSet +import Name +import Id +import IdInfo +import GHC.Core.Ppr +import ErrUtils +import Coercion +import SrcLoc +import Type +import GHC.Types.RepType +import TyCoRep -- checks validity of types/coercions +import TyCoSubst +import TyCoFVs +import TyCoPpr ( pprTyVar ) +import TyCon +import CoAxiom +import BasicTypes +import ErrUtils as Err +import ListSetOps +import PrelNames +import Outputable +import FastString +import Util +import InstEnv ( instanceDFunId ) +import OptCoercion ( checkAxInstCo ) +import GHC.Core.Arity ( typeArity ) +import Demand ( splitStrictSig, isBotDiv ) + +import GHC.Driver.Types +import GHC.Driver.Session +import Control.Monad +import qualified Control.Monad.Fail as MonadFail +import MonadUtils +import Data.Foldable ( toList ) +import Data.List.NonEmpty ( NonEmpty ) +import Data.Maybe +import Pair +import qualified GHC.LanguageExtensions as LangExt + +{- +Note [Core Lint guarantee] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Core Lint is the type-checker for Core. Using it, we get the following guarantee: + +If all of: +1. Core Lint passes, +2. there are no unsafe coercions (i.e. unsafeEqualityProof), +3. all plugin-supplied coercions (i.e. PluginProv) are valid, and +4. all case-matches are complete +then running the compiled program will not seg-fault, assuming no bugs downstream +(e.g. in the code generator). This guarantee is quite powerful, in that it allows us +to decouple the safety of the resulting program from the type inference algorithm. + +However, do note point (4) above. Core Lint does not check for incomplete case-matches; +see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there, +an incomplete case-match might slip by Core Lint and cause trouble at runtime. + +Note [GHC Formalism] +~~~~~~~~~~~~~~~~~~~~ +This file implements the type-checking algorithm for System FC, the "official" +name of the Core language. Type safety of FC is heart of the claim that +executables produced by GHC do not have segmentation faults. Thus, it is +useful to be able to reason about System FC independently of reading the code. +To this purpose, there is a document core-spec.pdf built in docs/core-spec that +contains a formalism of the types and functions dealt with here. If you change +just about anything in this file or you change other types/functions throughout +the Core language (all signposted to this note), you should update that +formalism. See docs/core-spec/README for more info about how to do so. + +Note [check vs lint] +~~~~~~~~~~~~~~~~~~~~ +This file implements both a type checking algorithm and also general sanity +checking. For example, the "sanity checking" checks for TyConApp on the left +of an AppTy, which should never happen. These sanity checks don't really +affect any notion of type soundness. Yet, it is convenient to do the sanity +checks at the same time as the type checks. So, we use the following naming +convention: + +- Functions that begin with 'lint'... are involved in type checking. These + functions might also do some sanity checking. + +- Functions that begin with 'check'... are *not* involved in type checking. + They exist only for sanity checking. + +Issues surrounding variable naming, shadowing, and such are considered *not* +to be part of type checking, as the formalism omits these details. + +Summary of checks +~~~~~~~~~~~~~~~~~ +Checks that a set of core bindings is well-formed. The PprStyle and String +just control what we print in the event of an error. The Bool value +indicates whether we have done any specialisation yet (in which case we do +some extra checks). + +We check for + (a) type errors + (b) Out-of-scope type variables + (c) Out-of-scope local variables + (d) Ill-kinded types + (e) Incorrect unsafe coercions + +If we have done specialisation the we check that there are + (a) No top-level bindings of primitive (unboxed type) + +Outstanding issues: + + -- Things are *not* OK if: + -- + -- * Unsaturated type app before specialisation has been done; + -- + -- * Oversaturated type app after specialisation (eta reduction + -- may well be happening...); + + +Note [Linting function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Representation of function types], all saturated +applications of funTyCon are represented with the FunTy constructor. We check +this invariant in lintType. + +Note [Linting type lets] +~~~~~~~~~~~~~~~~~~~~~~~~ +In the desugarer, it's very very convenient to be able to say (in effect) + let a = Type Int in <body> +That is, use a type let. See Note [Type let] in GHC.Core. + +However, when linting <body> we need to remember that a=Int, else we might +reject a correct program. So we carry a type substitution (in this example +[a -> Int]) and apply this substitution before comparing types. The function + lintInTy :: Type -> LintM (Type, Kind) +returns a substituted type. + +When we encounter a binder (like x::a) we must apply the substitution +to the type of the binding variable. lintBinders does this. + +For Ids, the type-substituted Id is added to the in_scope set (which +itself is part of the TCvSubst we are carrying down), and when we +find an occurrence of an Id, we fetch it from the in-scope set. + +Note [Bad unsafe coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions +Linter introduces additional rules that checks improper coercion between +different types, called bad coercions. Following coercions are forbidden: + + (a) coercions between boxed and unboxed values; + (b) coercions between unlifted values of the different sizes, here + active size is checked, i.e. size of the actual value but not + the space allocated for value; + (c) coercions between floating and integral boxed values, this check + is not yet supported for unboxed tuples, as no semantics were + specified for that; + (d) coercions from / to vector type + (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be + coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules + (a-e) holds. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +We check the rules listed in Note [Invariants on join points] in GHC.Core. The +only one that causes any difficulty is the first: All occurrences must be tail +calls. To this end, along with the in-scope set, we remember in le_joins the +subset of in-scope Ids that are valid join ids. For example: + + join j x = ... in + case e of + A -> jump j y -- good + B -> case (jump j z) of -- BAD + C -> join h = jump j w in ... -- good + D -> let x = jump j v in ... -- BAD + +A join point remains valid in case branches, so when checking the A +branch, j is still valid. When we check the scrutinee of the inner +case, however, we set le_joins to empty, and catch the +error. Similarly, join points can occur free in RHSes of other join +points but not the RHSes of value bindings (thunks and functions). + +************************************************************************ +* * + Beginning and ending passes +* * +************************************************************************ + +These functions are not CoreM monad stuff, but they probably ought to +be, and it makes a convenient place for them. They print out stuff +before and after core passes, and do Core Lint when necessary. +-} + +endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () +endPass pass binds rules + = do { hsc_env <- getHscEnv + ; print_unqual <- getPrintUnqualified + ; liftIO $ endPassIO hsc_env print_unqual pass binds rules } + +endPassIO :: HscEnv -> PrintUnqualified + -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () +-- Used by the IO-is CorePrep too +endPassIO hsc_env print_unqual pass binds rules + = do { dumpPassResult dflags print_unqual mb_flag + (ppr pass) (pprPassDetails pass) binds rules + ; lintPassResult hsc_env pass binds } + where + dflags = hsc_dflags hsc_env + mb_flag = case coreDumpFlag pass of + Just flag | dopt flag dflags -> Just flag + | dopt Opt_D_verbose_core2core dflags -> Just flag + _ -> Nothing + +dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () +dumpIfSet dflags dump_me pass extra_info doc + = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc + +dumpPassResult :: DynFlags + -> PrintUnqualified + -> Maybe DumpFlag -- Just df => show details in a file whose + -- name is specified by df + -> SDoc -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult dflags unqual mb_flag hdr extra_info binds rules + = do { forM_ mb_flag $ \flag -> do + let sty = mkDumpStyle dflags unqual + dumpAction dflags sty (dumpOptionsFromFlag flag) + (showSDoc dflags hdr) FormatCore dump_doc + + -- Report result size + -- This has the side effect of forcing the intermediate to be evaluated + -- if it's not already forced by a -ddump flag. + ; Err.debugTraceMsg dflags 2 size_doc + } + + where + size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] + + dump_doc = vcat [ nest 2 extra_info + , size_doc + , blankLine + , pprCoreBindingsWithSize binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , text "------ Local rules for imported ids --------" + , pprRules rules ] + +coreDumpFlag :: CoreToDo -> Maybe DumpFlag +coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity +coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify +coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal +coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal +coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper +coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec +coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec +coreDumpFlag CoreCSE = Just Opt_D_dump_cse +coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt +coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds +coreDumpFlag CoreTidy = Just Opt_D_dump_simpl +coreDumpFlag CorePrep = Just Opt_D_dump_prep +coreDumpFlag CoreOccurAnal = Just Opt_D_dump_occur_anal + +coreDumpFlag CoreDoPrintCore = Nothing +coreDumpFlag (CoreDoRuleCheck {}) = Nothing +coreDumpFlag CoreDoNothing = Nothing +coreDumpFlag (CoreDoPasses {}) = Nothing + +{- +************************************************************************ +* * + Top-level interfaces +* * +************************************************************************ +-} + +lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO () +lintPassResult hsc_env pass binds + | not (gopt Opt_DoCoreLinting dflags) + = return () + | otherwise + = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds + ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass) + ; displayLintResults dflags pass warns errs binds } + where + dflags = hsc_dflags hsc_env + +displayLintResults :: DynFlags -> CoreToDo + -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram + -> IO () +displayLintResults dflags pass warns errs binds + | not (isEmptyBag errs) + = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan + (defaultDumpStyle dflags) + (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs + , text "*** Offending Program ***" + , pprCoreBindings binds + , text "*** End of Offense ***" ]) + ; Err.ghcExit dflags 1 } + + | not (isEmptyBag warns) + , not (hasNoDebugOutput dflags) + , showLintWarnings pass + -- If the Core linter encounters an error, output to stderr instead of + -- stdout (#13342) + = putLogMsg dflags NoReason Err.SevInfo noSrcSpan + (defaultDumpStyle dflags) + (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) + + | otherwise = return () + where + +lint_banner :: String -> SDoc -> SDoc +lint_banner string pass = text "*** Core Lint" <+> text string + <+> text ": in result of" <+> pass + <+> text "***" + +showLintWarnings :: CoreToDo -> Bool +-- Disable Lint warnings on the first simplifier pass, because +-- there may be some INLINE knots still tied, which is tiresomely noisy +showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False +showLintWarnings _ = True + +lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO () +lintInteractiveExpr what hsc_env expr + | not (gopt Opt_DoCoreLinting dflags) + = return () + | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr + = do { display_lint_err err + ; Err.ghcExit dflags 1 } + | otherwise + = return () + where + dflags = hsc_dflags hsc_env + + display_lint_err err + = do { putLogMsg dflags NoReason Err.SevDump + noSrcSpan (defaultDumpStyle dflags) + (vcat [ lint_banner "errors" (text what) + , err + , text "*** Offending Program ***" + , pprCoreExpr expr + , text "*** End of Offense ***" ]) + ; Err.ghcExit dflags 1 } + +interactiveInScope :: HscEnv -> [Var] +-- In GHCi we may lint expressions, or bindings arising from 'deriving' +-- clauses, that mention variables bound in the interactive context. +-- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types). +-- So we have to tell Lint about them, lest it reports them as out of scope. +-- +-- We do this by find local-named things that may appear free in interactive +-- context. This function is pretty revolting and quite possibly not quite right. +-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty +-- so this is a (cheap) no-op. +-- +-- See #8215 for an example +interactiveInScope hsc_env + = tyvars ++ ids + where + -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr + ictxt = hsc_IC hsc_env + (cls_insts, _fam_insts) = ic_instances ictxt + te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) + te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts) + ids = typeEnvIds te + tyvars = tyCoVarsOfTypesList $ map idType ids + -- Why the type variables? How can the top level envt have free tyvars? + -- I think it's because of the GHCi debugger, which can bind variables + -- f :: [t] -> [t] + -- where t is a RuntimeUnk (see TcType) + +-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. +lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) +-- Returns (warnings, errors) +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreBindings dflags pass local_in_scope binds + = initL dflags flags in_scope_set $ + addLoc TopLevelBindings $ + lintLetBndrs TopLevel binders $ + -- Put all the top-level binders in scope at the start + -- This is because transformation rules can bring something + -- into use 'unexpectedly' + do { checkL (null dups) (dupVars dups) + ; checkL (null ext_dups) (dupExtVars ext_dups) + ; mapM lint_bind binds } + where + in_scope_set = mkInScopeSet (mkVarSet local_in_scope) + + flags = defaultLintFlags + { lf_check_global_ids = check_globals + , lf_check_inline_loop_breakers = check_lbs + , lf_check_static_ptrs = check_static_ptrs } + + -- See Note [Checking for global Ids] + check_globals = case pass of + CoreTidy -> False + CorePrep -> False + _ -> True + + -- See Note [Checking for INLINE loop breakers] + check_lbs = case pass of + CoreDesugar -> False + CoreDesugarOpt -> False + _ -> True + + -- See Note [Checking StaticPtrs] + check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere + | otherwise = case pass of + CoreDoFloatOutwards _ -> AllowAtTopLevel + CoreTidy -> RejectEverywhere + CorePrep -> AllowAtTopLevel + _ -> AllowAnywhere + + binders = bindersOfBinds binds + (_, dups) = removeDups compare binders + + -- dups_ext checks for names with different uniques + -- but but the same External name M.n. We don't + -- allow this at top level: + -- M.n{r3} = ... + -- M.n{r29} = ... + -- because they both get the same linker symbol + ext_dups = snd (removeDups ord_ext (map Var.varName binders)) + ord_ext n1 n2 | Just m1 <- nameModule_maybe n1 + , Just m2 <- nameModule_maybe n2 + = compare (m1, nameOccName n1) (m2, nameOccName n2) + | otherwise = LT + + -- If you edit this function, you may need to update the GHC formalism + -- See Note [GHC Formalism] + lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs + lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs) + +{- +************************************************************************ +* * +\subsection[lintUnfolding]{lintUnfolding} +* * +************************************************************************ + +Note [Linting Unfoldings from Interfaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We use this to check all top-level unfoldings that come in from interfaces +(it is very painful to catch errors otherwise). + +We do not need to call lintUnfolding on unfoldings that are nested within +top-level unfoldings; they are linted when we lint the top-level unfolding; +hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore. + +-} + +lintUnfolding :: Bool -- True <=> is a compulsory unfolding + -> DynFlags + -> SrcLoc + -> VarSet -- Treat these as in scope + -> CoreExpr + -> Maybe MsgDoc -- Nothing => OK + +lintUnfolding is_compulsory dflags locn vars expr + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + in_scope = mkInScopeSet vars + (_warns, errs) = initL dflags defaultLintFlags in_scope $ + if is_compulsory + -- See Note [Checking for levity polymorphism] + then noLPChecks linter + else linter + linter = addLoc (ImportedUnfolding locn) $ + lintCoreExpr expr + +lintExpr :: DynFlags + -> [Var] -- Treat these as in scope + -> CoreExpr + -> Maybe MsgDoc -- Nothing => OK + +lintExpr dflags vars expr + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + in_scope = mkInScopeSet (mkVarSet vars) + (_warns, errs) = initL dflags defaultLintFlags in_scope linter + linter = addLoc TopLevelBindings $ + lintCoreExpr expr + +{- +************************************************************************ +* * +\subsection[lintCoreBinding]{lintCoreBinding} +* * +************************************************************************ + +Check a core binding, returning the list of variables bound. +-} + +lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintSingleBinding top_lvl_flag rec_flag (binder,rhs) + = addLoc (RhsOf binder) $ + -- Check the rhs + do { ty <- lintRhs binder rhs + ; binder_ty <- applySubstTy (idType binder) + ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty) + + -- If the binding is for a CoVar, the RHS should be (Coercion co) + -- See Note [Core type and coercion invariant] in GHC.Core + ; checkL (not (isCoVar binder) || isCoArg rhs) + (mkLetErr binder rhs) + + -- Check that it's not levity-polymorphic + -- Do this first, because otherwise isUnliftedType panics + -- Annoyingly, this duplicates the test in lintIdBdr, + -- because for non-rec lets we call lintSingleBinding first + ; checkL (isJoinId binder || not (isTypeLevPoly binder_ty)) + (badBndrTyMsg binder (text "levity-polymorphic")) + + -- Check the let/app invariant + -- See Note [Core let/app invariant] in GHC.Core + ; checkL ( isJoinId binder + || not (isUnliftedType binder_ty) + || (isNonRec rec_flag && exprOkForSpeculation rhs) + || exprIsTickedString rhs) + (badBndrTyMsg binder (text "unlifted")) + + -- Check that if the binder is top-level or recursive, it's not + -- demanded. Primitive string literals are exempt as there is no + -- computation to perform, see Note [Core top-level string literals]. + ; checkL (not (isStrictId binder) + || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)) + || exprIsTickedString rhs) + (mkStrictMsg binder) + + -- Check that if the binder is at the top level and has type Addr#, + -- that it is a string literal, see + -- Note [Core top-level string literals]. + ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy) + || exprIsTickedString rhs) + (mkTopNonLitStrMsg binder) + + ; flags <- getLintFlags + + -- Check that a join-point binder has a valid type + -- NB: lintIdBinder has checked that it is not top-level bound + ; case isJoinId_maybe binder of + Nothing -> return () + Just arity -> checkL (isValidJoinPointType arity binder_ty) + (mkInvalidJoinPointMsg binder binder_ty) + + ; when (lf_check_inline_loop_breakers flags + && isStableUnfolding (realIdUnfolding binder) + && isStrongLoopBreaker (idOccInfo binder) + && isInlinePragma (idInlinePragma binder)) + (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) + -- Only non-rule loop breakers inhibit inlining + + -- We used to check that the dmdTypeDepth of a demand signature never + -- exceeds idArity, but that is an unnecessary complication, see + -- Note [idArity varies independently of dmdTypeDepth] in DmdAnal + + -- Check that the binder's arity is within the bounds imposed by + -- the type and the strictness signature. See Note [exprArity invariant] + -- and Note [Trimming arity] + ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder) + (text "idArity" <+> ppr (idArity binder) <+> + text "exceeds typeArity" <+> + ppr (length (typeArity (idType binder))) <> colon <+> + ppr binder) + + ; case splitStrictSig (idStrictness binder) of + (demands, result_info) | isBotDiv result_info -> + checkL (demands `lengthAtLeast` idArity binder) + (text "idArity" <+> ppr (idArity binder) <+> + text "exceeds arity imposed by the strictness signature" <+> + ppr (idStrictness binder) <> colon <+> + ppr binder) + _ -> return () + + ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + + ; addLoc (UnfoldingOf binder) $ + lintIdUnfolding binder binder_ty (idUnfolding binder) } + + -- We should check the unfolding, if any, but this is tricky because + -- the unfolding is a SimplifiableCoreExpr. Give up for now. + +-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' +-- in that it doesn't reject occurrences of the function 'makeStatic' when they +-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and +-- for join points, it skips the outer lambdas that take arguments to the +-- join point. +-- +-- See Note [Checking StaticPtrs]. +lintRhs :: Id -> CoreExpr -> LintM OutType +lintRhs bndr rhs + | Just arity <- isJoinId_maybe bndr + = lint_join_lams arity arity True rhs + | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) + = lint_join_lams arity arity False rhs + where + lint_join_lams 0 _ _ rhs + = lintCoreExpr rhs + + lint_join_lams n tot enforce (Lam var expr) + = lintLambda var $ lint_join_lams (n-1) tot enforce expr + + lint_join_lams n tot True _other + = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs + lint_join_lams _ _ False rhs + = markAllJoinsBad $ lintCoreExpr rhs + -- Future join point, not yet eta-expanded + -- Body is not a tail position + +-- Allow applications of the data constructor @StaticPtr@ at the top +-- but produce errors otherwise. +lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go + where + -- Allow occurrences of 'makeStatic' at the top-level but produce errors + -- otherwise. + go AllowAtTopLevel + | (binders0, rhs') <- collectTyBinders rhs + , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' + = markAllJoinsBad $ + foldr + -- imitate @lintCoreExpr (Lam ...)@ + lintLambda + -- imitate @lintCoreExpr (App ...)@ + (do fun_ty <- lintCoreExpr fun + lintCoreArgs fun_ty [Type t, info, e] + ) + binders0 + go _ = markAllJoinsBad $ lintCoreExpr rhs + +lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () +lintIdUnfolding bndr bndr_ty uf + | isStableUnfolding uf + , Just rhs <- maybeUnfoldingTemplate uf + = do { ty <- if isCompulsoryUnfolding uf + then noLPChecks $ lintRhs bndr rhs + -- See Note [Checking for levity polymorphism] + else lintRhs bndr rhs + ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } +lintIdUnfolding _ _ _ + = return () -- Do not Lint unstable unfoldings, because that leads + -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars + +{- +Note [Checking for INLINE loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very suspicious if a strong loop breaker is marked INLINE. + +However, the desugarer generates instance methods with INLINE pragmas +that form a mutually recursive group. Only after a round of +simplification are they unravelled. So we suppress the test for +the desugarer. + +Note [Checking for levity polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We ordinarily want to check for bad levity polymorphism. See +Note [Levity polymorphism invariants] in GHC.Core. However, we do *not* +want to do this in a compulsory unfolding. Compulsory unfoldings arise +only internally, for things like newtype wrappers, dictionaries, and +(notably) unsafeCoerce#. These might legitimately be levity-polymorphic; +indeed levity-polyorphic unfoldings are a primary reason for the +very existence of compulsory unfoldings (we can't compile code for +the original, levity-poly, binding). + +It is vitally important that we do levity-polymorphism checks *after* +performing the unfolding, but not beforehand. This is all safe because +we will check any unfolding after it has been unfolded; checking the +unfolding beforehand is merely an optimization, and one that actively +hurts us here. + +************************************************************************ +* * +\subsection[lintCoreExpr]{lintCoreExpr} +* * +************************************************************************ +-} + +-- For OutType, OutKind, the substitution has been applied, +-- but has not been linted yet + +type LintedType = Type -- Substitution applied, and type is linted +type LintedKind = Kind + +lintCoreExpr :: CoreExpr -> LintM OutType +-- The returned type has the substitution from the monad +-- already applied to it: +-- lintCoreExpr e subst = exprType (subst e) +-- +-- The returned "type" can be a kind, if the expression is (Type ty) + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreExpr (Var var) + = lintVarOcc var 0 + +lintCoreExpr (Lit lit) + = return (literalType lit) + +lintCoreExpr (Cast expr co) + = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr + ; co' <- applySubstCo co + ; (_, k2, from_ty, to_ty, r) <- lintCoercion co' + ; checkValueKind k2 (text "target of cast" <+> quotes (ppr co)) + ; lintRole co' Representational r + ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) + ; return to_ty } + +lintCoreExpr (Tick tickish expr) + = do case tickish of + Breakpoint _ ids -> forM_ ids $ \id -> do + checkDeadIdOcc id + lookupIdInScope id + _ -> return () + markAllJoinsBadIf block_joins $ lintCoreExpr expr + where + block_joins = not (tickish `tickishScopesLike` SoftScope) + -- TODO Consider whether this is the correct rule. It is consistent with + -- the simplifier's behaviour - cost-centre-scoped ticks become part of + -- the continuation, and thus they behave like part of an evaluation + -- context, but soft-scoped and non-scoped ticks simply wrap the result + -- (see Simplify.simplTick). + +lintCoreExpr (Let (NonRec tv (Type ty)) body) + | isTyVar tv + = -- See Note [Linting type lets] + do { ty' <- applySubstTy ty + ; lintTyBndr tv $ \ tv' -> + do { addLoc (RhsOf tv) $ lintTyKind tv' ty' + -- Now extend the substitution so we + -- take advantage of it in the body + ; extendSubstL tv ty' $ + addLoc (BodyOfLetRec [tv]) $ + lintCoreExpr body } } + +lintCoreExpr (Let (NonRec bndr rhs) body) + | isId bndr + = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) + ; addLoc (BodyOfLetRec [bndr]) + (lintBinder LetBind bndr $ \_ -> + addGoodJoins [bndr] $ + lintCoreExpr body) } + + | otherwise + = failWithL (mkLetErr bndr rhs) -- Not quite accurate + +lintCoreExpr e@(Let (Rec pairs) body) + = lintLetBndrs NotTopLevel bndrs $ + addGoodJoins bndrs $ + do { -- Check that the list of pairs is non-empty + checkL (not (null pairs)) (emptyRec e) + + -- Check that there are no duplicated binders + ; checkL (null dups) (dupVars dups) + + -- Check that either all the binders are joins, or none + ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ + mkInconsistentRecMsg bndrs + + ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs + ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) } + where + bndrs = map fst pairs + (_, dups) = removeDups compare bndrs + +lintCoreExpr e@(App _ _) + = do { fun_ty <- lintCoreFun fun (length args) + ; lintCoreArgs fun_ty args } + where + (fun, args) = collectArgs e + +lintCoreExpr (Lam var expr) + = markAllJoinsBad $ + lintLambda var $ lintCoreExpr expr + +lintCoreExpr (Case scrut var alt_ty alts) + = lintCaseExpr scrut var alt_ty alts + +-- This case can't happen; linting types in expressions gets routed through +-- lintCoreArgs +lintCoreExpr (Type ty) + = failWithL (text "Type found as expression" <+> ppr ty) + +lintCoreExpr (Coercion co) + = do { (k1, k2, ty1, ty2, role) <- lintInCo co + ; return (mkHeteroCoercionType role k1 k2 ty1 ty2) } + +---------------------- +lintVarOcc :: Var -> Int -- Number of arguments (type or value) being passed + -> LintM Type -- returns type of the *variable* +lintVarOcc var nargs + = do { checkL (isNonCoVarId var) + (text "Non term variable" <+> ppr var) + -- See GHC.Core Note [Variable occurrences in Core] + + -- Cneck that the type of the occurrence is the same + -- as the type of the binding site + ; ty <- applySubstTy (idType var) + ; var' <- lookupIdInScope var + ; let ty' = idType var' + ; ensureEqTys ty ty' $ mkBndrOccTypeMismatchMsg var' var ty' ty + + -- Check for a nested occurrence of the StaticPtr constructor. + -- See Note [Checking StaticPtrs]. + ; lf <- getLintFlags + ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ + checkL (idName var /= makeStaticName) $ + text "Found makeStatic nested in an expression" + + ; checkDeadIdOcc var + ; checkJoinOcc var nargs + + ; return (idType var') } + +lintCoreFun :: CoreExpr + -> Int -- Number of arguments (type or val) being passed + -> LintM Type -- Returns type of the *function* +lintCoreFun (Var var) nargs + = lintVarOcc var nargs + +lintCoreFun (Lam var body) nargs + -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see + -- Note [Beta redexes] + | nargs /= 0 + = lintLambda var $ lintCoreFun body (nargs - 1) + +lintCoreFun expr nargs + = markAllJoinsBadIf (nargs /= 0) $ + -- See Note [Join points are less general than the paper] + lintCoreExpr expr +------------------ +lintLambda :: Var -> LintM Type -> LintM Type +lintLambda var lintBody = + addLoc (LambdaBodyOf var) $ + lintBinder LambdaBind var $ \ var' -> + do { body_ty <- lintBody + ; return (mkLamType var' body_ty) } +------------------ +checkDeadIdOcc :: Id -> LintM () +-- Occurrences of an Id should never be dead.... +-- except when we are checking a case pattern +checkDeadIdOcc id + | isDeadOcc (idOccInfo id) + = do { in_case <- inCasePat + ; checkL in_case + (text "Occurrence of a dead Id" <+> ppr id) } + | otherwise + = return () + +------------------ +checkJoinOcc :: Id -> JoinArity -> LintM () +-- Check that if the occurrence is a JoinId, then so is the +-- binding site, and it's a valid join Id +checkJoinOcc var n_args + | Just join_arity_occ <- isJoinId_maybe var + = do { mb_join_arity_bndr <- lookupJoinId var + ; case mb_join_arity_bndr of { + Nothing -> -- Binder is not a join point + addErrL (invalidJoinOcc var) ; + + Just join_arity_bndr -> + + do { checkL (join_arity_bndr == join_arity_occ) $ + -- Arity differs at binding site and occurrence + mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ + + ; checkL (n_args == join_arity_occ) $ + -- Arity doesn't match #args + mkBadJumpMsg var join_arity_occ n_args } } } + + | otherwise + = return () + +{- +Note [No alternatives lint check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case expressions with no alternatives are odd beasts, and it would seem +like they would worth be looking at in the linter (cf #10180). We +used to check two things: + +* exprIsHNF is false: it would *seem* to be terribly wrong if + the scrutinee was already in head normal form. + +* exprIsBottom is true: we should be able to see why GHC believes the + scrutinee is diverging for sure. + +It was already known that the second test was not entirely reliable. +Unfortunately (#13990), the first test turned out not to be reliable +either. Getting the checks right turns out to be somewhat complicated. + +For example, suppose we have (comment 8) + + data T a where + TInt :: T Int + + absurdTBool :: T Bool -> a + absurdTBool v = case v of + + data Foo = Foo !(T Bool) + + absurdFoo :: Foo -> a + absurdFoo (Foo x) = absurdTBool x + +GHC initially accepts the empty case because of the GADT conditions. But then +we inline absurdTBool, getting + + absurdFoo (Foo x) = case x of + +x is in normal form (because the Foo constructor is strict) but the +case is empty. To avoid this problem, GHC would have to recognize +that matching on Foo x is already absurd, which is not so easy. + +More generally, we don't really know all the ways that GHC can +lose track of why an expression is bottom, so we shouldn't make too +much fuss when that happens. + + +Note [Beta redexes] +~~~~~~~~~~~~~~~~~~~ +Consider: + + join j @x y z = ... in + (\@x y z -> jump j @x y z) @t e1 e2 + +This is clearly ill-typed, since the jump is inside both an application and a +lambda, either of which is enough to disqualify it as a tail call (see Note +[Invariants on join points] in GHC.Core). However, strictly from a +lambda-calculus perspective, the term doesn't go wrong---after the two beta +reductions, the jump *is* a tail call and everything is fine. + +Why would we want to allow this when we have let? One reason is that a compound +beta redex (that is, one with more than one argument) has different scoping +rules: naively reducing the above example using lets will capture any free +occurrence of y in e2. More fundamentally, type lets are tricky; many passes, +such as Float Out, tacitly assume that the incoming program's type lets have +all been dealt with by the simplifier. Thus we don't want to let-bind any types +in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately +before Float Out. + +All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this +loophole, doing so to avoid re-traversing large functions (beta-reducing a type +lambda without introducing a type let requires a substitution). TODO: Improve +simpleOptPgm so that we can forget all this ever happened. + +************************************************************************ +* * +\subsection[lintCoreArgs]{lintCoreArgs} +* * +************************************************************************ + +The basic version of these functions checks that the argument is a +subtype of the required type, as one would expect. +-} + + +lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType +lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args + +lintCoreArg :: OutType -> CoreArg -> LintM OutType +lintCoreArg fun_ty (Type arg_ty) + = do { checkL (not (isCoercionTy arg_ty)) + (text "Unnecessary coercion-to-type injection:" + <+> ppr arg_ty) + ; arg_ty' <- applySubstTy arg_ty + ; lintTyApp fun_ty arg_ty' } + +lintCoreArg fun_ty arg + = do { arg_ty <- markAllJoinsBad $ lintCoreExpr arg + -- See Note [Levity polymorphism invariants] in GHC.Core + ; flags <- getLintFlags + ; lintL (not (lf_check_levity_poly flags) || not (isTypeLevPoly arg_ty)) + (text "Levity-polymorphic argument:" <+> + (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty)))) + -- check for levity polymorphism first, because otherwise isUnliftedType panics + + ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg) + (mkLetAppMsg arg) + ; lintValApp arg fun_ty arg_ty } + +----------------- +lintAltBinders :: OutType -- Scrutinee type + -> OutType -- Constructor type + -> [OutVar] -- Binders + -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintAltBinders scrut_ty con_ty [] + = ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) +lintAltBinders scrut_ty con_ty (bndr:bndrs) + | isTyVar bndr + = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) + ; lintAltBinders scrut_ty con_ty' bndrs } + | otherwise + = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr) + ; lintAltBinders scrut_ty con_ty' bndrs } + +----------------- +lintTyApp :: OutType -> OutType -> LintM OutType +lintTyApp fun_ty arg_ty + | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty + = do { lintTyKind tv arg_ty + ; in_scope <- getInScope + -- substTy needs the set of tyvars in scope to avoid generating + -- uniques that are already in scope. + -- See Note [The substitution invariant] in TyCoSubst + ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } + + | otherwise + = failWithL (mkTyAppMsg fun_ty arg_ty) + +----------------- +lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType +lintValApp arg fun_ty arg_ty + | Just (arg,res) <- splitFunTy_maybe fun_ty + = do { ensureEqTys arg arg_ty err1 + ; return res } + | otherwise + = failWithL err2 + where + err1 = mkAppMsg fun_ty arg_ty arg + err2 = mkNonFunAppMsg fun_ty arg_ty arg + +lintTyKind :: OutTyVar -> OutType -> LintM () +-- Both args have had substitution applied + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintTyKind tyvar arg_ty + = do { arg_kind <- lintType arg_ty + ; unless (arg_kind `eqType` tyvar_kind) + (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))) } + where + tyvar_kind = tyVarKind tyvar + +{- +************************************************************************ +* * +\subsection[lintCoreAlts]{lintCoreAlts} +* * +************************************************************************ +-} + +lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM OutType +lintCaseExpr scrut var alt_ty alts = + do { let e = Case scrut var alt_ty alts -- Just for error messages + + -- Check the scrutinee + ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut + -- See Note [Join points are less general than the paper] + -- in GHC.Core + + ; (alt_ty, _) <- addLoc (CaseTy scrut) $ + lintInTy alt_ty + ; (var_ty, _) <- addLoc (IdTy var) $ + lintInTy (idType var) + + -- We used to try to check whether a case expression with no + -- alternatives was legitimate, but this didn't work. + -- See Note [No alternatives lint check] for details. + + -- Check that the scrutinee is not a floating-point type + -- if there are any literal alternatives + -- See GHC.Core Note [Case expression invariants] item (5) + -- See Note [Rules for floating-point comparisons] in PrelRules + ; let isLitPat (LitAlt _, _ , _) = True + isLitPat _ = False + ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts) + (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++ + "expression with literal pattern in case " ++ + "analysis (see #9238).") + $$ text "scrut" <+> ppr scrut) + + ; case tyConAppTyCon_maybe (idType var) of + Just tycon + | debugIsOn + , isAlgTyCon tycon + , not (isAbstractTyCon tycon) + , null (tyConDataCons tycon) + , not (exprIsBottom scrut) + -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) + -- This can legitimately happen for type families + $ return () + _otherwise -> return () + + -- Don't use lintIdBndr on var, because unboxed tuple is legitimate + + ; subst <- getTCvSubst + ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) + -- See GHC.Core Note [Case expression invariants] item (7) + + ; lintBinder CaseBind var $ \_ -> + do { -- Check the alternatives + mapM_ (lintCoreAlt scrut_ty alt_ty) alts + ; checkCaseAlts e scrut_ty alts + ; return alt_ty } } + +checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM () +-- a) Check that the alts are non-empty +-- b1) Check that the DEFAULT comes first, if it exists +-- b2) Check that the others are in increasing order +-- c) Check that there's a default for infinite types +-- NB: Algebraic cases are not necessarily exhaustive, because +-- the simplifier correctly eliminates case that can't +-- possibly match. + +checkCaseAlts e ty alts = + do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) + -- See GHC.Core Note [Case expression invariants] item (2) + + ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) + -- See GHC.Core Note [Case expression invariants] item (3) + + -- For types Int#, Word# with an infinite (well, large!) number of + -- possible values, there should usually be a DEFAULT case + -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to + -- have *no* case alternatives. + -- In effect, this is a kind of partial test. I suppose it's possible + -- that we might *know* that 'x' was 1 or 2, in which case + -- case x of { 1 -> e1; 2 -> e2 } + -- would be fine. + ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) + (nonExhaustiveAltsMsg e) } + where + (con_alts, maybe_deflt) = findDefault alts + + -- Check that successive alternatives have strictly increasing tags + increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest + increasing_tag _ = True + + non_deflt (DEFAULT, _, _) = False + non_deflt _ = True + + is_infinite_ty = case tyConAppTyCon_maybe ty of + Nothing -> False + Just tycon -> isPrimTyCon tycon + +lintAltExpr :: CoreExpr -> OutType -> LintM () +lintAltExpr expr ann_ty + = do { actual_ty <- lintCoreExpr expr + ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) } + -- See GHC.Core Note [Case expression invariants] item (6) + +lintCoreAlt :: OutType -- Type of scrutinee + -> OutType -- Type of the alternative + -> CoreAlt + -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreAlt _ alt_ty (DEFAULT, args, rhs) = + do { lintL (null args) (mkDefaultArgsMsg args) + ; lintAltExpr rhs alt_ty } + +lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) + | litIsLifted lit + = failWithL integerScrutinisedMsg + | otherwise + = do { lintL (null args) (mkDefaultArgsMsg args) + ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) + ; lintAltExpr rhs alt_ty } + where + lit_ty = literalType lit + +lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) + | isNewTyCon (dataConTyCon con) + = addErrL (mkNewTyDataConAltMsg scrut_ty alt) + | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty + = addLoc (CaseAlt alt) $ do + { -- First instantiate the universally quantified + -- type variables of the data constructor + -- We've already check + lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) + ; let con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys + + -- And now bring the new binders into scope + ; lintBinders CasePatBind args $ \ args' -> do + { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args') + ; lintAltExpr rhs alt_ty } } + + | otherwise -- Scrut-ty is wrong shape + = addErrL (mkBadAltMsg scrut_ty alt) + +{- +************************************************************************ +* * +\subsection[lint-types]{Types} +* * +************************************************************************ +-} + +-- When we lint binders, we (one at a time and in order): +-- 1. Lint var types or kinds (possibly substituting) +-- 2. Add the binder to the in scope set, and if its a coercion var, +-- we may extend the substitution to reflect its (possibly) new kind +lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a +lintBinders _ [] linterF = linterF [] +lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> + lintBinders site vars $ \ vars' -> + linterF (var':vars') + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a +lintBinder site var linterF + | isTyVar var = lintTyBndr var linterF + | isCoVar var = lintCoBndr var linterF + | otherwise = lintIdBndr NotTopLevel site var linterF + +lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a +lintTyBndr tv thing_inside + = do { subst <- getTCvSubst + ; let (subst', tv') = substTyVarBndr subst tv + ; lintKind (varType tv') + ; updateTCvSubst subst' (thing_inside tv') } + +lintCoBndr :: InCoVar -> (OutCoVar -> LintM a) -> LintM a +lintCoBndr cv thing_inside + = do { subst <- getTCvSubst + ; let (subst', cv') = substCoVarBndr subst cv + ; lintKind (varType cv') + ; lintL (isCoVarType (varType cv')) + (text "CoVar with non-coercion type:" <+> pprTyVar cv) + ; updateTCvSubst subst' (thing_inside cv') } + +lintLetBndrs :: TopLevelFlag -> [Var] -> LintM a -> LintM a +lintLetBndrs top_lvl ids linterF + = go ids + where + go [] = linterF + go (id:ids) = lintIdBndr top_lvl LetBind id $ \_ -> + go ids + +lintIdBndr :: TopLevelFlag -> BindingSite + -> InVar -> (OutVar -> LintM a) -> LintM a +-- Do substitution on the type of a binder and add the var with this +-- new type to the in-scope set of the second argument +-- ToDo: lint its rules +lintIdBndr top_lvl bind_site id linterF + = ASSERT2( isId id, ppr id ) + do { flags <- getLintFlags + ; checkL (not (lf_check_global_ids flags) || isLocalId id) + (text "Non-local Id binder" <+> ppr id) + -- See Note [Checking for global Ids] + + -- Check that if the binder is nested, it is not marked as exported + ; checkL (not (isExportedId id) || is_top_lvl) + (mkNonTopExportedMsg id) + + -- Check that if the binder is nested, it does not have an external name + ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl) + (mkNonTopExternalNameMsg id) + + ; (ty, k) <- addLoc (IdTy id) $ + lintInTy (idType id) + + -- See Note [Levity polymorphism invariants] in GHC.Core + ; lintL (isJoinId id || not (lf_check_levity_poly flags) || not (isKindLevPoly k)) + (text "Levity-polymorphic binder:" <+> + (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k))) + + -- Check that a join-id is a not-top-level let-binding + ; when (isJoinId id) $ + checkL (not is_top_lvl && is_let_bind) $ + mkBadJoinBindMsg id + + -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2); + -- if so, it should be a CoVar, and checked by lintCoVarBndr + ; lintL (not (isCoVarType ty)) + (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr ty) + + ; let id' = setIdType id ty + ; addInScopeVar id' $ (linterF id') } + where + is_top_lvl = isTopLevel top_lvl + is_let_bind = case bind_site of + LetBind -> True + _ -> False + +{- +%************************************************************************ +%* * + Types +%* * +%************************************************************************ +-} + +lintTypes :: DynFlags + -> [TyCoVar] -- Treat these as in scope + -> [Type] + -> Maybe MsgDoc -- Nothing => OK +lintTypes dflags vars tys + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + in_scope = emptyInScopeSet + (_warns, errs) = initL dflags defaultLintFlags in_scope linter + linter = lintBinders LambdaBind vars $ \_ -> + mapM_ lintInTy tys + +lintInTy :: InType -> LintM (LintedType, LintedKind) +-- Types only, not kinds +-- Check the type, and apply the substitution to it +-- See Note [Linting type lets] +lintInTy ty + = addLoc (InType ty) $ + do { ty' <- applySubstTy ty + ; k <- lintType ty' + ; lintKind k -- The kind returned by lintType is already + -- a LintedKind but we also want to check that + -- k :: *, which lintKind does + ; return (ty', k) } + +checkTyCon :: TyCon -> LintM () +checkTyCon tc + = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) + +------------------- +lintType :: OutType -> LintM LintedKind +-- The returned Kind has itself been linted + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintType (TyVarTy tv) + = do { checkL (isTyVar tv) (mkBadTyVarMsg tv) + ; lintTyCoVarInScope tv + ; return (tyVarKind tv) } + -- We checked its kind when we added it to the envt + +lintType ty@(AppTy t1 t2) + | TyConApp {} <- t1 + = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty + | otherwise + = do { k1 <- lintType t1 + ; k2 <- lintType t2 + ; lint_ty_app ty k1 [(t2,k2)] } + +lintType ty@(TyConApp tc tys) + | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags + ; lintTySynFamApp report_unsat ty tc tys } + + | isFunTyCon tc + , tys `lengthIs` 4 + -- We should never see a saturated application of funTyCon; such + -- applications should be represented with the FunTy constructor. + -- See Note [Linting function types] and + -- Note [Representation of function types]. + = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty)) + + | otherwise -- Data types, data families, primitive types + = do { checkTyCon tc + ; ks <- mapM lintType tys + ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } + +-- arrows can related *unlifted* kinds, so this has to be separate from +-- a dependent forall. +lintType ty@(FunTy _ t1 t2) + = do { k1 <- lintType t1 + ; k2 <- lintType t2 + ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 } + +lintType t@(ForAllTy (Bndr tv _vis) ty) + -- forall over types + | isTyVar tv + = lintTyBndr tv $ \tv' -> + do { k <- lintType ty + ; checkValueKind k (text "the body of forall:" <+> ppr t) + ; case occCheckExpand [tv'] k of -- See Note [Stupid type synonyms] + Just k' -> return k' + Nothing -> failWithL (hang (text "Variable escape in forall:") + 2 (vcat [ text "type:" <+> ppr t + , text "kind:" <+> ppr k ])) + } + +lintType t@(ForAllTy (Bndr cv _vis) ty) + -- forall over coercions + = do { lintL (isCoVar cv) + (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr t) + ; lintL (cv `elemVarSet` tyCoVarsOfType ty) + (text "Covar does not occur in the body:" <+> ppr t) + ; lintCoBndr cv $ \_ -> + do { k <- lintType ty + ; checkValueKind k (text "the body of forall:" <+> ppr t) + ; return liftedTypeKind + -- We don't check variable escape here. Namely, k could refer to cv' + -- See Note [NthCo and newtypes] in TyCoRep + }} + +lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) + +lintType (CastTy ty co) + = do { k1 <- lintType ty + ; (k1', k2) <- lintStarCoercion co + ; ensureEqTys k1 k1' (mkCastTyErr ty co k1' k1) + ; return k2 } + +lintType (CoercionTy co) + = do { (k1, k2, ty1, ty2, r) <- lintCoercion co + ; return $ mkHeteroCoercionType r k1 k2 ty1 ty2 } + +{- Note [Stupid type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14939) + type Alg cls ob = ob + f :: forall (cls :: * -> Constraint) (b :: Alg cls *). b + +Here 'cls' appears free in b's kind, which would usually be illegal +(because in (forall a. ty), ty's kind should not mention 'a'). But +#in this case (Alg cls *) = *, so all is well. Currently we allow +this, and make Lint expand synonyms where necessary to make it so. + +c.f. TcUnify.occCheckExpand and GHC.Core.Utils.coreAltsType which deal +with the same problem. A single systematic solution eludes me. +-} + +----------------- +lintTySynFamApp :: Bool -> Type -> TyCon -> [Type] -> LintM LintedKind +-- The TyCon is a type synonym or a type family (not a data family) +-- See Note [Linting type synonym applications] +-- c.f. TcValidity.check_syn_tc_app +lintTySynFamApp report_unsat ty tc tys + | report_unsat -- Report unsaturated only if report_unsat is on + , tys `lengthLessThan` tyConArity tc + = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) + + -- Deal with type synonyms + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' + = do { -- Kind-check the argument types, but without reporting + -- un-saturated type families/synonyms + ks <- setReportUnsat False (mapM lintType tys) + + ; when report_unsat $ + do { _ <- lintType expanded_ty + ; return () } + + ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } + + -- Otherwise this must be a type family + | otherwise + = do { ks <- mapM lintType tys + ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } + +----------------- +lintKind :: OutKind -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintKind k = do { sk <- lintType k + ; unless (classifiesTypeWithValues sk) + (addErrL (hang (text "Ill-kinded kind:" <+> ppr k) + 2 (text "has kind:" <+> ppr sk))) } + +----------------- +-- Confirms that a type is really *, #, Constraint etc +checkValueKind :: OutKind -> SDoc -> LintM () +checkValueKind k doc + = lintL (classifiesTypeWithValues k) + (text "Non-*-like kind when *-like expected:" <+> ppr k $$ + text "when checking" <+> doc) + +----------------- +lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintArrow what k1 k2 -- Eg lintArrow "type or kind `blah'" k1 k2 + -- or lintarrow "coercion `blah'" k1 k2 + = do { unless (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1)) + ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result") k2)) + ; return liftedTypeKind } + where + msg ar k + = vcat [ hang (text "Ill-kinded" <+> ar) + 2 (text "in" <+> what) + , what <+> text "kind:" <+> ppr k ] + +----------------- +lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind +lint_ty_app ty k tys + = lint_app (text "type" <+> quotes (ppr ty)) k tys + +---------------- +lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind +lint_co_app ty k tys + = lint_app (text "coercion" <+> quotes (ppr ty)) k tys + +---------------- +lintTyLit :: TyLit -> LintM () +lintTyLit (NumTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = text "Negative type literal:" <+> integer n +lintTyLit (StrTyLit _) = return () + +lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind +-- (lint_app d fun_kind arg_tys) +-- We have an application (f arg_ty1 .. arg_tyn), +-- where f :: fun_kind +-- Takes care of linting the OutTypes + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lint_app doc kfn kas + = do { in_scope <- getInScope + -- We need the in_scope set to satisfy the invariant in + -- Note [The substitution invariant] in TyCoSubst + ; foldlM (go_app in_scope) kfn kas } + where + fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc + , nest 2 (text "Function kind =" <+> ppr kfn) + , nest 2 (text "Arg kinds =" <+> ppr kas) + , extra ] + + go_app in_scope kfn tka + | Just kfn' <- coreView kfn + = go_app in_scope kfn' tka + + go_app _ (FunTy _ kfa kfb) tka@(_,ka) + = do { unless (ka `eqType` kfa) $ + addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka))) + ; return kfb } + + go_app in_scope (ForAllTy (Bndr kv _vis) kfn) tka@(ta,ka) + = do { let kv_kind = varType kv + ; unless (ka `eqType` kv_kind) $ + addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ ppr tka))) + ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn } + + go_app _ kfn ka + = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ka))) + +{- ********************************************************************* +* * + Linting rules +* * +********************************************************************* -} + +lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM () +lintCoreRule _ _ (BuiltinRule {}) + = return () -- Don't bother + +lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs + , ru_args = args, ru_rhs = rhs }) + = lintBinders LambdaBind bndrs $ \ _ -> + do { lhs_ty <- lintCoreArgs fun_ty args + ; rhs_ty <- case isJoinId_maybe fun of + Just join_arity + -> do { checkL (args `lengthIs` join_arity) $ + mkBadJoinPointRuleMsg fun join_arity rule + -- See Note [Rules for join points] + ; lintCoreExpr rhs } + _ -> markAllJoinsBad $ lintCoreExpr rhs + ; ensureEqTys lhs_ty rhs_ty $ + (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty + , text "rhs type:" <+> ppr rhs_ty + , text "fun_ty:" <+> ppr fun_ty ]) + ; let bad_bndrs = filter is_bad_bndr bndrs + + ; checkL (null bad_bndrs) + (rule_doc <+> text "unbound" <+> ppr bad_bndrs) + -- See Note [Linting rules] + } + where + rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon + + lhs_fvs = exprsFreeVars args + rhs_fvs = exprFreeVars rhs + + is_bad_bndr :: Var -> Bool + -- See Note [Unbound RULE binders] in GHC.Core.Rules + is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs) + && bndr `elemVarSet` rhs_fvs + && isNothing (isReflCoVar_maybe bndr) + + +{- Note [Linting rules] +~~~~~~~~~~~~~~~~~~~~~~~ +It's very bad if simplifying a rule means that one of the template +variables (ru_bndrs) that /is/ mentioned on the RHS becomes +not-mentioned in the LHS (ru_args). How can that happen? Well, in +#10602, SpecConstr stupidly constructed a rule like + + forall x,c1,c2. + f (x |> c1 |> c2) = .... + +But simplExpr collapses those coercions into one. (Indeed in +#10602, it collapsed to the identity and was removed altogether.) + +We don't have a great story for what to do here, but at least +this check will nail it. + +NB (#11643): it's possible that a variable listed in the +binders becomes not-mentioned on both LHS and RHS. Here's a silly +example: + RULE forall x y. f (g x y) = g (x+1) (y-1) +And suppose worker/wrapper decides that 'x' is Absent. Then +we'll end up with + RULE forall x y. f ($gw y) = $gw (x+1) +This seems sufficiently obscure that there isn't enough payoff to +try to trim the forall'd binder list. + +Note [Rules for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A join point cannot be partially applied. However, the left-hand side of a rule +for a join point is effectively a *pattern*, not a piece of code, so there's an +argument to be made for allowing a situation like this: + + join $sj :: Int -> Int -> String + $sj n m = ... + j :: forall a. Eq a => a -> a -> String + {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-} + j @a $dEq x y = ... + +Applying this rule can't turn a well-typed program into an ill-typed one, so +conceivably we could allow it. But we can always eta-expand such an +"undersaturated" rule (see 'GHC.Core.Arity.etaExpandToJoinPointRule'), and in fact +the simplifier would have to in order to deal with the RHS. So we take a +conservative view and don't allow undersaturated rules for join points. See +Note [Rules and join points] in OccurAnal for further discussion. +-} + +{- +************************************************************************ +* * + Linting coercions +* * +************************************************************************ +-} + +lintInCo :: InCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role) +-- Check the coercion, and apply the substitution to it +-- See Note [Linting type lets] +lintInCo co + = addLoc (InCo co) $ + do { co' <- applySubstCo co + ; lintCoercion co' } + +-- lints a coercion, confirming that its lh kind and its rh kind are both * +-- also ensures that the role is Nominal +lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType) +lintStarCoercion g + = do { (k1, k2, t1, t2, r) <- lintCoercion g + ; checkValueKind k1 (text "the kind of the left type in" <+> ppr g) + ; checkValueKind k2 (text "the kind of the right type in" <+> ppr g) + ; lintRole g Nominal r + ; return (t1, t2) } + +lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role) +-- Check the kind of a coercion term, returning the kind +-- Post-condition: the returned OutTypes are lint-free +-- +-- If lintCoercion co = (k1, k2, s1, s2, r) +-- then co :: s1 ~r s2 +-- s1 :: k1 +-- s2 :: k2 + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoercion (Refl ty) + = do { k <- lintType ty + ; return (k, k, ty, ty, Nominal) } + +lintCoercion (GRefl r ty MRefl) + = do { k <- lintType ty + ; return (k, k, ty, ty, r) } + +lintCoercion (GRefl r ty (MCo co)) + = do { k <- lintType ty + ; (_, _, k1, k2, r') <- lintCoercion co + ; ensureEqTys k k1 + (hang (text "GRefl coercion kind mis-match:" <+> ppr co) + 2 (vcat [ppr ty, ppr k, ppr k1])) + ; lintRole co Nominal r' + ; return (k1, k2, ty, mkCastTy ty co, r) } + +lintCoercion co@(TyConAppCo r tc cos) + | tc `hasKey` funTyConKey + , [_rep1,_rep2,_co1,_co2] <- cos + = do { failWithL (text "Saturated TyConAppCo (->):" <+> ppr co) + } -- All saturated TyConAppCos should be FunCos + + | Just {} <- synTyConDefn_maybe tc + = failWithL (text "Synonym in TyConAppCo:" <+> ppr co) + + | otherwise + = do { checkTyCon tc + ; (k's, ks, ss, ts, rs) <- mapAndUnzip5M lintCoercion cos + ; k' <- lint_co_app co (tyConKind tc) (ss `zip` k's) + ; k <- lint_co_app co (tyConKind tc) (ts `zip` ks) + ; _ <- zipWith3M lintRole cos (tyConRolesX r tc) rs + ; return (k', k, mkTyConApp tc ss, mkTyConApp tc ts, r) } + +lintCoercion co@(AppCo co1 co2) + | TyConAppCo {} <- co1 + = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) + | Just (TyConApp {}, _) <- isReflCo_maybe co1 + = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) + | otherwise + = do { (k1, k2, s1, s2, r1) <- lintCoercion co1 + ; (k'1, k'2, t1, t2, r2) <- lintCoercion co2 + ; k3 <- lint_co_app co k1 [(t1,k'1)] + ; k4 <- lint_co_app co k2 [(t2,k'2)] + ; if r1 == Phantom + then lintL (r2 == Phantom || r2 == Nominal) + (text "Second argument in AppCo cannot be R:" $$ + ppr co) + else lintRole co Nominal r2 + ; return (k3, k4, mkAppTy s1 t1, mkAppTy s2 t2, r1) } + +---------- +lintCoercion (ForAllCo tv1 kind_co co) + -- forall over types + | isTyVar tv1 + = do { (_, k2) <- lintStarCoercion kind_co + ; let tv2 = setTyVarKind tv1 k2 + ; addInScopeVar tv1 $ + do { + ; (k3, k4, t1, t2, r) <- lintCoercion co + ; in_scope <- getInScope + ; let tyl = mkInvForAllTy tv1 t1 + subst = mkTvSubst in_scope $ + -- We need both the free vars of the `t2` and the + -- free vars of the range of the substitution in + -- scope. All the free vars of `t2` and `kind_co` should + -- already be in `in_scope`, because they've been + -- linted and `tv2` has the same unique as `tv1`. + -- See Note [The substitution invariant] in TyCoSubst. + unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co) + tyr = mkInvForAllTy tv2 $ + substTy subst t2 + ; return (k3, k4, tyl, tyr, r) } } + +lintCoercion (ForAllCo cv1 kind_co co) + -- forall over coercions + = ASSERT( isCoVar cv1 ) + do { lintL (almostDevoidCoVarOfCo cv1 co) + (text "Covar can only appear in Refl and GRefl: " <+> ppr co) + ; (_, k2) <- lintStarCoercion kind_co + ; let cv2 = setVarType cv1 k2 + ; addInScopeVar cv1 $ + do { + ; (k3, k4, t1, t2, r) <- lintCoercion co + ; checkValueKind k3 (text "the body of a ForAllCo over covar:" <+> ppr co) + ; checkValueKind k4 (text "the body of a ForAllCo over covar:" <+> ppr co) + -- See Note [Weird typing rule for ForAllTy] in Type + ; in_scope <- getInScope + ; let tyl = mkTyCoInvForAllTy cv1 t1 + r2 = coVarRole cv1 + kind_co' = downgradeRole r2 Nominal kind_co + eta1 = mkNthCo r2 2 kind_co' + eta2 = mkNthCo r2 3 kind_co' + subst = mkCvSubst in_scope $ + -- We need both the free vars of the `t2` and the + -- free vars of the range of the substitution in + -- scope. All the free vars of `t2` and `kind_co` should + -- already be in `in_scope`, because they've been + -- linted and `cv2` has the same unique as `cv1`. + -- See Note [The substitution invariant] in TyCoSubst. + unitVarEnv cv1 (eta1 `mkTransCo` (mkCoVarCo cv2) + `mkTransCo` (mkSymCo eta2)) + tyr = mkTyCoInvForAllTy cv2 $ + substTy subst t2 + ; return (liftedTypeKind, liftedTypeKind, tyl, tyr, r) } } + -- See Note [Weird typing rule for ForAllTy] in Type + +lintCoercion co@(FunCo r co1 co2) + = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1 + ; (k2,k'2,s2,t2,r2) <- lintCoercion co2 + ; k <- lintArrow (text "coercion" <+> quotes (ppr co)) k1 k2 + ; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2 + ; lintRole co1 r r1 + ; lintRole co2 r r2 + ; return (k, k', mkVisFunTy s1 s2, mkVisFunTy t1 t2, r) } + +lintCoercion (CoVarCo cv) + | not (isCoVar cv) + = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv) + 2 (text "With offending type:" <+> ppr (varType cv))) + | otherwise + = do { lintTyCoVarInScope cv + ; cv' <- lookupIdInScope cv + ; lintUnliftedCoVar cv + ; return $ coVarKindsTypesRole cv' } + +-- See Note [Bad unsafe coercion] +lintCoercion co@(UnivCo prov r ty1 ty2) + = do { k1 <- lintType ty1 + ; k2 <- lintType ty2 + ; case prov of + PhantomProv kco -> do { lintRole co Phantom r + ; check_kinds kco k1 k2 } + + ProofIrrelProv kco -> do { lintL (isCoercionTy ty1) $ + mkBadProofIrrelMsg ty1 co + ; lintL (isCoercionTy ty2) $ + mkBadProofIrrelMsg ty2 co + ; check_kinds kco k1 k2 } + + PluginProv _ -> return () -- no extra checks + + ; when (r /= Phantom && classifiesTypeWithValues k1 + && classifiesTypeWithValues k2) + (checkTypes ty1 ty2) + ; return (k1, k2, ty1, ty2, r) } + where + report s = hang (text $ "Unsafe coercion: " ++ s) + 2 (vcat [ text "From:" <+> ppr ty1 + , text " To:" <+> ppr ty2]) + isUnBoxed :: PrimRep -> Bool + isUnBoxed = not . isGcPtrRep + + -- see #9122 for discussion of these checks + checkTypes t1 t2 + = do { checkWarnL (not lev_poly1) + (report "left-hand type is levity-polymorphic") + ; checkWarnL (not lev_poly2) + (report "right-hand type is levity-polymorphic") + ; when (not (lev_poly1 || lev_poly2)) $ + do { checkWarnL (reps1 `equalLength` reps2) + (report "between values with different # of reps") + ; zipWithM_ validateCoercion reps1 reps2 }} + where + lev_poly1 = isTypeLevPoly t1 + lev_poly2 = isTypeLevPoly t2 + + -- don't look at these unless lev_poly1/2 are False + -- Otherwise, we get #13458 + reps1 = typePrimRep t1 + reps2 = typePrimRep t2 + + validateCoercion :: PrimRep -> PrimRep -> LintM () + validateCoercion rep1 rep2 + = do { dflags <- getDynFlags + ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) + (report "between unboxed and boxed value") + ; checkWarnL (TyCon.primRepSizeB dflags rep1 + == TyCon.primRepSizeB dflags rep2) + (report "between unboxed values of different size") + ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) + (TyCon.primRepIsFloat rep2) + ; case fl of + Nothing -> addWarnL (report "between vector types") + Just False -> addWarnL (report "between float and integral values") + _ -> return () + } + + check_kinds kco k1 k2 = do { (k1', k2') <- lintStarCoercion kco + ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co) + ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) } + + +lintCoercion (SymCo co) + = do { (k1, k2, ty1, ty2, r) <- lintCoercion co + ; return (k2, k1, ty2, ty1, r) } + +lintCoercion co@(TransCo co1 co2) + = do { (k1a, _k1b, ty1a, ty1b, r1) <- lintCoercion co1 + ; (_k2a, k2b, ty2a, ty2b, r2) <- lintCoercion co2 + ; ensureEqTys ty1b ty2a + (hang (text "Trans coercion mis-match:" <+> ppr co) + 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) + ; lintRole co r1 r2 + ; return (k1a, k2b, ty1a, ty2b, r1) } + +lintCoercion the_co@(NthCo r0 n co) + = do { (_, _, s, t, r) <- lintCoercion co + ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of + { (Just (tcv_s, _ty_s), Just (tcv_t, _ty_t)) + -- works for both tyvar and covar + | n == 0 + , (isForAllTy_ty s && isForAllTy_ty t) + || (isForAllTy_co s && isForAllTy_co t) + -> do { lintRole the_co Nominal r0 + ; return (ks, kt, ts, tt, r0) } + where + ts = varType tcv_s + tt = varType tcv_t + ks = typeKind ts + kt = typeKind tt + + ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of + { (Just (tc_s, tys_s), Just (tc_t, tys_t)) + | tc_s == tc_t + , isInjectiveTyCon tc_s r + -- see Note [NthCo and newtypes] in TyCoRep + , tys_s `equalLength` tys_t + , tys_s `lengthExceeds` n + -> do { lintRole the_co tr r0 + ; return (ks, kt, ts, tt, r0) } + where + ts = getNth tys_s n + tt = getNth tys_t n + tr = nthRole r tc_s n + ks = typeKind ts + kt = typeKind tt + + ; _ -> failWithL (hang (text "Bad getNth:") + 2 (ppr the_co $$ ppr s $$ ppr t)) }}} + +lintCoercion the_co@(LRCo lr co) + = do { (_,_,s,t,r) <- lintCoercion co + ; lintRole co Nominal r + ; case (splitAppTy_maybe s, splitAppTy_maybe t) of + (Just s_pr, Just t_pr) + -> return (ks_pick, kt_pick, s_pick, t_pick, Nominal) + where + s_pick = pickLR lr s_pr + t_pick = pickLR lr t_pr + ks_pick = typeKind s_pick + kt_pick = typeKind t_pick + + _ -> failWithL (hang (text "Bad LRCo:") + 2 (ppr the_co $$ ppr s $$ ppr t)) } + +lintCoercion (InstCo co arg) + = do { (k3, k4, t1',t2', r) <- lintCoercion co + ; (k1',k2',s1,s2, r') <- lintCoercion arg + ; lintRole arg Nominal r' + ; in_scope <- getInScope + ; case (splitForAllTy_ty_maybe t1', splitForAllTy_ty_maybe t2') of + -- forall over tvar + { (Just (tv1,t1), Just (tv2,t2)) + | k1' `eqType` tyVarKind tv1 + , k2' `eqType` tyVarKind tv2 + -> return (k3, k4, + substTyWithInScope in_scope [tv1] [s1] t1, + substTyWithInScope in_scope [tv2] [s2] t2, r) + | otherwise + -> failWithL (text "Kind mis-match in inst coercion") + ; _ -> case (splitForAllTy_co_maybe t1', splitForAllTy_co_maybe t2') of + -- forall over covar + { (Just (cv1, t1), Just (cv2, t2)) + | k1' `eqType` varType cv1 + , k2' `eqType` varType cv2 + , CoercionTy s1' <- s1 + , CoercionTy s2' <- s2 + -> do { return $ + (liftedTypeKind, liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in Type + , substTy (mkCvSubst in_scope $ unitVarEnv cv1 s1') t1 + , substTy (mkCvSubst in_scope $ unitVarEnv cv2 s2') t2 + , r) } + | otherwise + -> failWithL (text "Kind mis-match in inst coercion") + ; _ -> failWithL (text "Bad argument of inst") }}} + +lintCoercion co@(AxiomInstCo con ind cos) + = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) + (bad_ax (text "index out of range")) + ; let CoAxBranch { cab_tvs = ktvs + , cab_cvs = cvs + , cab_roles = roles + , cab_lhs = lhs + , cab_rhs = rhs } = coAxiomNthBranch con ind + ; unless (cos `equalLength` (ktvs ++ cvs)) $ + bad_ax (text "lengths") + ; subst <- getTCvSubst + ; let empty_subst = zapTCvSubst subst + ; (subst_l, subst_r) <- foldlM check_ki + (empty_subst, empty_subst) + (zip3 (ktvs ++ cvs) roles cos) + ; let lhs' = substTys subst_l lhs + rhs' = substTy subst_r rhs + fam_tc = coAxiomTyCon con + ; case checkAxInstCo co of + Just bad_branch -> bad_ax $ text "inconsistent with" <+> + pprCoAxBranch fam_tc bad_branch + Nothing -> return () + ; let s2 = mkTyConApp fam_tc lhs' + ; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) } + where + bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what) + 2 (ppr co)) + + check_ki (subst_l, subst_r) (ktv, role, arg) + = do { (k', k'', s', t', r) <- lintCoercion arg + ; lintRole arg role r + ; let ktv_kind_l = substTy subst_l (tyVarKind ktv) + ktv_kind_r = substTy subst_r (tyVarKind ktv) + ; unless (k' `eqType` ktv_kind_l) + (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr k', ppr ktv, ppr ktv_kind_l ] )) + ; unless (k'' `eqType` ktv_kind_r) + (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr k'', ppr ktv, ppr ktv_kind_r ] )) + ; return (extendTCvSubst subst_l ktv s', + extendTCvSubst subst_r ktv t') } + +lintCoercion (KindCo co) + = do { (k1, k2, _, _, _) <- lintCoercion co + ; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) } + +lintCoercion (SubCo co') + = do { (k1,k2,s,t,r) <- lintCoercion co' + ; lintRole co' Nominal r + ; return (k1,k2,s,t,Representational) } + +lintCoercion this@(AxiomRuleCo co cs) + = do { eqs <- mapM lintCoercion cs + ; lintRoles 0 (coaxrAsmpRoles co) eqs + ; case coaxrProves co [ Pair l r | (_,_,l,r,_) <- eqs ] of + Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] + Just (Pair l r) -> + return (typeKind l, typeKind r, l, r, coaxrRole co) } + where + err m xs = failWithL $ + hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName co) : xs) + + lintRoles n (e : es) ((_,_,_,_,r) : rs) + | e == r = lintRoles (n+1) es rs + | otherwise = err "Argument roles mismatch" + [ text "In argument:" <+> int (n+1) + , text "Expected:" <+> ppr e + , text "Found:" <+> ppr r ] + lintRoles _ [] [] = return () + lintRoles n [] rs = err "Too many coercion arguments" + [ text "Expected:" <+> int n + , text "Provided:" <+> int (n + length rs) ] + + lintRoles n es [] = err "Not enough coercion arguments" + [ text "Expected:" <+> int (n + length es) + , text "Provided:" <+> int n ] + +lintCoercion (HoleCo h) + = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h + ; lintCoercion (CoVarCo (coHoleCoVar h)) } + + +---------- +lintUnliftedCoVar :: CoVar -> LintM () +lintUnliftedCoVar cv + = when (not (isUnliftedType (coVarKind cv))) $ + failWithL (text "Bad lifted equality:" <+> ppr cv + <+> dcolon <+> ppr (coVarKind cv)) + +{- +************************************************************************ +* * +\subsection[lint-monad]{The Lint monad} +* * +************************************************************************ +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] +data LintEnv + = LE { le_flags :: LintFlags -- Linting the result of this pass + , le_loc :: [LintLocInfo] -- Locations + + , le_subst :: TCvSubst -- Current type substitution + -- We also use le_subst to keep track of + -- /all variables/ in scope, both Ids and TyVars + + , le_joins :: IdSet -- Join points in scope that are valid + -- A subset of the InScopeSet in le_subst + -- See Note [Join points] + + , le_dynflags :: DynFlags -- DynamicFlags + } + +data LintFlags + = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] + , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] + , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs] + , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] + , lf_check_levity_poly :: Bool -- See Note [Checking for levity polymorphism] + } + +-- See Note [Checking StaticPtrs] +data StaticPtrCheck + = AllowAnywhere + -- ^ Allow 'makeStatic' to occur anywhere. + | AllowAtTopLevel + -- ^ Allow 'makeStatic' calls at the top-level only. + | RejectEverywhere + -- ^ Reject any 'makeStatic' occurrence. + deriving Eq + +defaultLintFlags :: LintFlags +defaultLintFlags = LF { lf_check_global_ids = False + , lf_check_inline_loop_breakers = True + , lf_check_static_ptrs = AllowAnywhere + , lf_report_unsat_syns = True + , lf_check_levity_poly = True + } + +newtype LintM a = + LintM { unLintM :: + LintEnv -> + WarnsAndErrs -> -- Warning and error messages so far + (Maybe a, WarnsAndErrs) } -- Result and messages (if any) + deriving (Functor) + +type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) + +{- Note [Checking for global Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before CoreTidy, all locally-bound Ids must be LocalIds, even +top-level ones. See Note [Exported LocalIds] and #9857. + +Note [Checking StaticPtrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [Grand plan for static forms] in StaticPtrTable for an overview. + +Every occurrence of the function 'makeStatic' should be moved to the +top level by the FloatOut pass. It's vital that we don't have nested +'makeStatic' occurrences after CorePrep, because we populate the Static +Pointer Table from the top-level bindings. See SimplCore Note [Grand +plan for static forms]. + +The linter checks that no occurrence is left behind, nested within an +expression. The check is enabled only after the FloatOut, CorePrep, +and CoreTidy passes and only if the module uses the StaticPointers +language extension. Checking more often doesn't help since the condition +doesn't hold until after the first FloatOut pass. + +Note [Type substitution] +~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we need a type substitution? Consider + /\(a:*). \(x:a). /\(a:*). id a x +This is ill typed, because (renaming variables) it is really + /\(a:*). \(x:a). /\(b:*). id b x +Hence, when checking an application, we can't naively compare x's type +(at its binding site) with its expected type (at a use site). So we +rename type binders as we go, maintaining a substitution. + +The same substitution also supports let-type, current expressed as + (/\(a:*). body) ty +Here we substitute 'ty' for 'a' in 'body', on the fly. + +Note [Linting type synonym applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When linting a type-synonym, or type-family, application + S ty1 .. tyn +we behave as follows (#15057, #T15664): + +* If lf_report_unsat_syns = True, and S has arity < n, + complain about an unsaturated type synonym or type family + +* Switch off lf_report_unsat_syns, and lint ty1 .. tyn. + + Reason: catch out of scope variables or other ill-kinded gubbins, + even if S discards that argument entirely. E.g. (#15012): + type FakeOut a = Int + type family TF a + type instance TF Int = FakeOut a + Here 'a' is out of scope; but if we expand FakeOut, we conceal + that out-of-scope error. + + Reason for switching off lf_report_unsat_syns: with + LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they + are saturated when the type is expanded. Example + type T f = f Int + type S a = a -> a + type Z = T S + In Z's RHS, S appears unsaturated, but it is saturated when T is expanded. + +* If lf_report_unsat_syns is on, expand the synonym application and + lint the result. Reason: want to check that synonyms are saturated + when the type is expanded. +-} + +instance Applicative LintM where + pure x = LintM $ \ _ errs -> (Just x, errs) + (<*>) = ap + +instance Monad LintM where +#if !MIN_VERSION_base(4,13,0) + fail = MonadFail.fail +#endif + m >>= k = LintM (\ env errs -> + let (res, errs') = unLintM m env errs in + case res of + Just r -> unLintM (k r) env errs' + Nothing -> (Nothing, errs')) + +instance MonadFail.MonadFail LintM where + fail err = failWithL (text err) + +instance HasDynFlags LintM where + getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs)) + +data LintLocInfo + = RhsOf Id -- The variable bound + | LambdaBodyOf Id -- The lambda-binder + | UnfoldingOf Id -- Unfolding of a binder + | BodyOfLetRec [Id] -- One of the binders + | CaseAlt CoreAlt -- Case alternative + | CasePat CoreAlt -- The *pattern* of the case alternative + | CaseTy CoreExpr -- The type field of a case expression + -- with this scrutinee + | IdTy Id -- The type field of an Id binder + | AnExpr CoreExpr -- Some expression + | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + | TopLevelBindings + | InType Type -- Inside a type + | InCo Coercion -- Inside a coercion + +initL :: DynFlags -> LintFlags -> InScopeSet + -> LintM a -> WarnsAndErrs -- Warnings and errors +initL dflags flags in_scope m + = case unLintM m env (emptyBag, emptyBag) of + (Just _, errs) -> errs + (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs + | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ + "without reporting an error message") empty + where + env = LE { le_flags = flags + , le_subst = mkEmptyTCvSubst in_scope + , le_joins = emptyVarSet + , le_loc = [] + , le_dynflags = dflags } + +setReportUnsat :: Bool -> LintM a -> LintM a +-- Switch off lf_report_unsat_syns +setReportUnsat ru thing_inside + = LintM $ \ env errs -> + let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } } + in unLintM thing_inside env' errs + +-- See Note [Checking for levity polymorphism] +noLPChecks :: LintM a -> LintM a +noLPChecks thing_inside + = LintM $ \env errs -> + let env' = env { le_flags = (le_flags env) { lf_check_levity_poly = False } } + in unLintM thing_inside env' errs + +getLintFlags :: LintM LintFlags +getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) + +checkL :: Bool -> MsgDoc -> LintM () +checkL True _ = return () +checkL False msg = failWithL msg + +-- like checkL, but relevant to type checking +lintL :: Bool -> MsgDoc -> LintM () +lintL = checkL + +checkWarnL :: Bool -> MsgDoc -> LintM () +checkWarnL True _ = return () +checkWarnL False msg = addWarnL msg + +failWithL :: MsgDoc -> LintM a +failWithL msg = LintM $ \ env (warns,errs) -> + (Nothing, (warns, addMsg True env errs msg)) + +addErrL :: MsgDoc -> LintM () +addErrL msg = LintM $ \ env (warns,errs) -> + (Just (), (warns, addMsg True env errs msg)) + +addWarnL :: MsgDoc -> LintM () +addWarnL msg = LintM $ \ env (warns,errs) -> + (Just (), (addMsg False env warns msg, errs)) + +addMsg :: Bool -> LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc +addMsg is_error env msgs msg + = ASSERT( notNull loc_msgs ) + msgs `snocBag` mk_msg msg + where + loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first + loc_msgs = map dumpLoc (le_loc env) + + cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs + , text "Substitution:" <+> ppr (le_subst env) ] + context | is_error = cxt_doc + | otherwise = whenPprDebug cxt_doc + -- Print voluminous info for Lint errors + -- but not for warnings + + msg_span = case [ span | (loc,_) <- loc_msgs + , let span = srcLocSpan loc + , isGoodSrcSpan span ] of + [] -> noSrcSpan + (s:_) -> s + mk_msg msg = mkLocMessage SevWarning msg_span + (msg $$ context) + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m + = LintM $ \ env errs -> + unLintM m (env { le_loc = extra_loc : le_loc env }) errs + +inCasePat :: LintM Bool -- A slight hack; see the unique call site +inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs) + where + is_case_pat (LE { le_loc = CasePat {} : _ }) = True + is_case_pat _other = False + +addInScopeVar :: Var -> LintM a -> LintM a +addInScopeVar var m + = LintM $ \ env errs -> + unLintM m (env { le_subst = extendTCvInScope (le_subst env) var + , le_joins = delVarSet (le_joins env) var + }) errs + +extendSubstL :: TyVar -> Type -> LintM a -> LintM a +extendSubstL tv ty m + = LintM $ \ env errs -> + unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs + +updateTCvSubst :: TCvSubst -> LintM a -> LintM a +updateTCvSubst subst' m + = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs + +markAllJoinsBad :: LintM a -> LintM a +markAllJoinsBad m + = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs + +markAllJoinsBadIf :: Bool -> LintM a -> LintM a +markAllJoinsBadIf True m = markAllJoinsBad m +markAllJoinsBadIf False m = m + +addGoodJoins :: [Var] -> LintM a -> LintM a +addGoodJoins vars thing_inside + = LintM $ \ env errs -> unLintM thing_inside (add_joins env) errs + where + add_joins env = env { le_joins = le_joins env `extendVarSetList` join_ids } + join_ids = filter isJoinId vars + +getValidJoins :: LintM IdSet +getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs)) + +getTCvSubst :: LintM TCvSubst +getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) + +getInScope :: LintM InScopeSet +getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs)) + +applySubstTy :: InType -> LintM OutType +applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) } + +applySubstCo :: InCoercion -> LintM OutCoercion +applySubstCo co = do { subst <- getTCvSubst; return (substCo subst co) } + +lookupIdInScope :: Id -> LintM Id +lookupIdInScope id_occ + = do { subst <- getTCvSubst + ; case lookupInScope (getTCvInScope subst) id_occ of + Just id_bnd -> do { checkL (not (bad_global id_bnd)) global_in_scope + ; return id_bnd } + Nothing -> do { checkL (not is_local) local_out_of_scope + ; return id_occ } } + where + is_local = mustHaveLocalBinding id_occ + local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ + global_in_scope = hang (text "Occurrence is GlobalId, but binding is LocalId") + 2 (pprBndr LetBind id_occ) + bad_global id_bnd = isGlobalId id_occ + && isLocalId id_bnd + && not (isWiredIn id_occ) + -- 'bad_global' checks for the case where an /occurrence/ is + -- a GlobalId, but there is an enclosing binding fora a LocalId. + -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr, + -- but GHCi adds GlobalIds from the interactive context. These + -- are fine; hence the test (isLocalId id == isLocalId v) + -- NB: when compiling Control.Exception.Base, things like absentError + -- are defined locally, but appear in expressions as (global) + -- wired-in Ids after worker/wrapper + -- So we simply disable the test in this case + +lookupJoinId :: Id -> LintM (Maybe JoinArity) +-- Look up an Id which should be a join point, valid here +-- If so, return its arity, if not return Nothing +lookupJoinId id + = do { join_set <- getValidJoins + ; case lookupVarSet join_set id of + Just id' -> return (isJoinId_maybe id') + Nothing -> return Nothing } + +lintTyCoVarInScope :: TyCoVar -> LintM () +lintTyCoVarInScope var + = do { subst <- getTCvSubst + ; lintL (var `isInScope` subst) + (hang (text "The variable" <+> pprBndr LetBind var) + 2 (text "is out of scope")) } + +ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM () +-- check ty2 is subtype of ty1 (ie, has same structure but usage +-- annotations need only be consistent, not equal) +-- Assumes ty1,ty2 are have already had the substitution applied +ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg + +lintRole :: Outputable thing + => thing -- where the role appeared + -> Role -- expected + -> Role -- actual + -> LintM () +lintRole co r1 r2 + = lintL (r1 == r2) + (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> + text "got" <+> ppr r2 $$ + text "in" <+> ppr co) + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) + +dumpLoc (RhsOf v) + = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v]) + +dumpLoc (LambdaBodyOf b) + = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b) + +dumpLoc (UnfoldingOf b) + = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b) + +dumpLoc (BodyOfLetRec []) + = (noSrcLoc, text "In body of a letrec with no binders") + +dumpLoc (BodyOfLetRec bs@(_:_)) + = ( getSrcLoc (head bs), text "In the body of letrec with binders" <+> pp_binders bs) + +dumpLoc (AnExpr e) + = (noSrcLoc, text "In the expression:" <+> ppr e) + +dumpLoc (CaseAlt (con, args, _)) + = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CasePat (con, args, _)) + = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CaseTy scrut) + = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:") + 2 (ppr scrut)) + +dumpLoc (IdTy b) + = (getSrcLoc b, text "In the type of a binder:" <+> ppr b) + +dumpLoc (ImportedUnfolding locn) + = (locn, text "In an imported unfolding") +dumpLoc TopLevelBindings + = (noSrcLoc, Outputable.empty) +dumpLoc (InType ty) + = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) +dumpLoc (InCo co) + = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) + +pp_binders :: [Var] -> SDoc +pp_binders bs = sep (punctuate comma (map pp_binder bs)) + +pp_binder :: Var -> SDoc +pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] + | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] + +------------------------------------------------------ +-- Messages for case expressions + +mkDefaultArgsMsg :: [Var] -> MsgDoc +mkDefaultArgsMsg args + = hang (text "DEFAULT case with binders") + 4 (ppr args) + +mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc +mkCaseAltMsg e ty1 ty2 + = hang (text "Type of case alternatives not the same as the annotation on case:") + 4 (vcat [ text "Actual type:" <+> ppr ty1, + text "Annotation on case:" <+> ppr ty2, + text "Alt Rhs:" <+> ppr e ]) + +mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc +mkScrutMsg var var_ty scrut_ty subst + = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, + text "Result binder type:" <+> ppr var_ty,--(idType var), + text "Scrutinee type:" <+> ppr scrut_ty, + hsep [text "Current TCv subst", ppr subst]] + +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc +mkNonDefltMsg e + = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) +mkNonIncreasingAltsMsg e + = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) + +nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc +nonExhaustiveAltsMsg e + = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) + +mkBadConMsg :: TyCon -> DataCon -> MsgDoc +mkBadConMsg tycon datacon + = vcat [ + text "In a case alternative, data constructor isn't in scrutinee type:", + text "Scrutinee type constructor:" <+> ppr tycon, + text "Data con:" <+> ppr datacon + ] + +mkBadPatMsg :: Type -> Type -> MsgDoc +mkBadPatMsg con_result_ty scrut_ty + = vcat [ + text "In a case alternative, pattern result type doesn't match scrutinee type:", + text "Pattern result type:" <+> ppr con_result_ty, + text "Scrutinee type:" <+> ppr scrut_ty + ] + +integerScrutinisedMsg :: MsgDoc +integerScrutinisedMsg + = text "In a LitAlt, the literal is lifted (probably Integer)" + +mkBadAltMsg :: Type -> CoreAlt -> MsgDoc +mkBadAltMsg scrut_ty alt + = vcat [ text "Data alternative when scrutinee is not a tycon application", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + +mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc +mkNewTyDataConAltMsg scrut_ty alt + = vcat [ text "Data alternative for newtype datacon", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + + +------------------------------------------------------ +-- Other error messages + +mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkAppMsg fun_ty arg_ty arg + = vcat [text "Argument value doesn't match argument type:", + hang (text "Fun type:") 4 (ppr fun_ty), + hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Arg:") 4 (ppr arg)] + +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkNonFunAppMsg fun_ty arg_ty arg + = vcat [text "Non-function type in function position", + hang (text "Fun type:") 4 (ppr fun_ty), + hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Arg:") 4 (ppr arg)] + +mkLetErr :: TyVar -> CoreExpr -> MsgDoc +mkLetErr bndr rhs + = vcat [text "Bad `let' binding:", + hang (text "Variable:") + 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), + hang (text "Rhs:") + 4 (ppr rhs)] + +mkTyAppMsg :: Type -> Type -> MsgDoc +mkTyAppMsg ty arg_ty + = vcat [text "Illegal type application:", + hang (text "Exp type:") + 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), + hang (text "Arg type:") + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +emptyRec :: CoreExpr -> MsgDoc +emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) + +mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc +mkRhsMsg binder what ty + = vcat + [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, + ppr binder], + hsep [text "Binder's type:", ppr (idType binder)], + hsep [text "Rhs type:", ppr ty]] + +mkLetAppMsg :: CoreExpr -> MsgDoc +mkLetAppMsg e + = hang (text "This argument does not satisfy the let/app invariant:") + 2 (ppr e) + +badBndrTyMsg :: Id -> SDoc -> MsgDoc +badBndrTyMsg binder what + = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder + , text "Binder's type:" <+> ppr (idType binder) ] + +mkStrictMsg :: Id -> MsgDoc +mkStrictMsg binder + = vcat [hsep [text "Recursive or top-level binder has strict demand info:", + ppr binder], + hsep [text "Binder's demand info:", ppr (idDemandInfo binder)] + ] + +mkNonTopExportedMsg :: Id -> MsgDoc +mkNonTopExportedMsg binder + = hsep [text "Non-top-level binder is marked as exported:", ppr binder] + +mkNonTopExternalNameMsg :: Id -> MsgDoc +mkNonTopExternalNameMsg binder + = hsep [text "Non-top-level binder has an external name:", ppr binder] + +mkTopNonLitStrMsg :: Id -> MsgDoc +mkTopNonLitStrMsg binder + = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] + +mkKindErrMsg :: TyVar -> Type -> MsgDoc +mkKindErrMsg tyvar arg_ty + = vcat [text "Kinds don't match in type application:", + hang (text "Type variable:") + 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), + hang (text "Arg type:") + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc +mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) + +mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc +mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty) + +mk_cast_err :: String -- ^ What sort of casted thing this is + -- (\"expression\" or \"type\"). + -> String -- ^ What sort of coercion is being used + -- (\"type\" or \"kind\"). + -> SDoc -- ^ The thing being casted. + -> Coercion -> Type -> Type -> MsgDoc +mk_cast_err thing_str co_str pp_thing co from_ty thing_ty + = vcat [from_msg <+> text "of Cast differs from" <+> co_msg + <+> text "of" <+> enclosed_msg, + from_msg <> colon <+> ppr from_ty, + text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon + <+> ppr thing_ty, + text "Actual" <+> enclosed_msg <> colon <+> pp_thing, + text "Coercion used in cast:" <+> ppr co + ] + where + co_msg, from_msg, enclosed_msg :: SDoc + co_msg = text co_str + from_msg = text "From-" <> co_msg + enclosed_msg = text "enclosed" <+> text thing_str + +mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc +mkBadUnivCoMsg lr co + = text "Kind mismatch on the" <+> pprLeftOrRight lr <+> + text "side of a UnivCo:" <+> ppr co + +mkBadProofIrrelMsg :: Type -> Coercion -> SDoc +mkBadProofIrrelMsg ty co + = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:") + 2 (vcat [ text "type:" <+> ppr ty + , text "co:" <+> ppr co ]) + +mkBadTyVarMsg :: Var -> SDoc +mkBadTyVarMsg tv + = text "Non-tyvar used in TyVarTy:" + <+> ppr tv <+> dcolon <+> ppr (varType tv) + +mkBadJoinBindMsg :: Var -> SDoc +mkBadJoinBindMsg var + = vcat [ text "Bad join point binding:" <+> ppr var + , text "Join points can be bound only by a non-top-level let" ] + +mkInvalidJoinPointMsg :: Var -> Type -> SDoc +mkInvalidJoinPointMsg var ty + = hang (text "Join point has invalid type:") + 2 (ppr var <+> dcolon <+> ppr ty) + +mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc +mkBadJoinArityMsg var ar nlams rhs + = vcat [ text "Join point has too few lambdas", + text "Join var:" <+> ppr var, + text "Join arity:" <+> ppr ar, + text "Number of lambdas:" <+> ppr nlams, + text "Rhs = " <+> ppr rhs + ] + +invalidJoinOcc :: Var -> SDoc +invalidJoinOcc var + = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var + , text "The binder is either not a join point, or not valid here" ] + +mkBadJumpMsg :: Var -> Int -> Int -> SDoc +mkBadJumpMsg var ar nargs + = vcat [ text "Join point invoked with wrong number of arguments", + text "Join var:" <+> ppr var, + text "Join arity:" <+> ppr ar, + text "Number of arguments:" <+> int nargs ] + +mkInconsistentRecMsg :: [Var] -> SDoc +mkInconsistentRecMsg bndrs + = vcat [ text "Recursive let binders mix values and join points", + text "Binders:" <+> hsep (map ppr_with_details bndrs) ] + where + ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr) + +mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc +mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ + = vcat [ text "Mismatch in join point arity between binder and occurrence" + , text "Var:" <+> ppr bndr + , text "Arity at binding site:" <+> ppr join_arity_bndr + , text "Arity at occurrence: " <+> ppr join_arity_occ ] + +mkBndrOccTypeMismatchMsg :: Var -> Var -> OutType -> OutType -> SDoc +mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty + = vcat [ text "Mismatch in type between binder and occurrence" + , text "Var:" <+> ppr bndr + , text "Binder type:" <+> ppr bndr_ty + , text "Occurrence type:" <+> ppr var_ty + , text " Before subst:" <+> ppr (idType var) ] + +mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc +mkBadJoinPointRuleMsg bndr join_arity rule + = vcat [ text "Join point has rule with wrong number of arguments" + , text "Var:" <+> ppr bndr + , text "Join arity:" <+> ppr join_arity + , text "Rule:" <+> ppr rule ] + +pprLeftOrRight :: LeftOrRight -> MsgDoc +pprLeftOrRight CLeft = text "left" +pprLeftOrRight CRight = text "right" + +dupVars :: [NonEmpty Var] -> MsgDoc +dupVars vars + = hang (text "Duplicate variables brought into scope") + 2 (ppr (map toList vars)) + +dupExtVars :: [NonEmpty Name] -> MsgDoc +dupExtVars vars + = hang (text "Duplicate top-level variables with the same qualified name") + 2 (ppr (map toList vars)) + +{- +************************************************************************ +* * +\subsection{Annotation Linting} +* * +************************************************************************ +-} + +-- | This checks whether a pass correctly looks through debug +-- annotations (@SourceNote@). This works a bit different from other +-- consistency checks: We check this by running the given task twice, +-- noting all differences between the results. +lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +lintAnnots pname pass guts = do + -- Run the pass as we normally would + dflags <- getDynFlags + when (gopt Opt_DoAnnotationLinting dflags) $ + liftIO $ Err.showPass dflags "Annotation linting - first run" + nguts <- pass guts + -- If appropriate re-run it without debug annotations to make sure + -- that they made no difference. + when (gopt Opt_DoAnnotationLinting dflags) $ do + liftIO $ Err.showPass dflags "Annotation linting - second run" + nguts' <- withoutAnnots pass guts + -- Finally compare the resulting bindings + liftIO $ Err.showPass dflags "Annotation linting - comparison" + let binds = flattenBinds $ mg_binds nguts + binds' = flattenBinds $ mg_binds nguts' + (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' + when (not (null diffs)) $ CoreMonad.putMsg $ vcat + [ lint_banner "warning" pname + , text "Core changes with annotations:" + , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs + ] + -- Return actual new guts + return nguts + +-- | Run the given pass without annotations. This means that we both +-- set the debugLevel setting to 0 in the environment as well as all +-- annotations from incoming modules. +withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +withoutAnnots pass guts = do + -- Remove debug flag from environment. + dflags <- getDynFlags + let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} } + withoutFlag corem = + -- TODO: supply tag here as well ? + liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*> + getUniqMask <*> getModule <*> + getVisibleOrphanMods <*> + getPrintUnqualified <*> getSrcSpanM <*> + pure corem + -- Nuke existing ticks in module. + -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes + -- them in absence of debugLevel > 0. + let nukeTicks = stripTicksE (not . tickishIsCode) + nukeAnnotsBind :: CoreBind -> CoreBind + nukeAnnotsBind bind = case bind of + Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs + NonRec b e -> NonRec b $ nukeTicks e + nukeAnnotsMod mg@ModGuts{mg_binds=binds} + = mg{mg_binds = map nukeAnnotsBind binds} + -- Perform pass with all changes applied + fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts) diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs new file mode 100644 index 0000000000..540ecfbe56 --- /dev/null +++ b/compiler/GHC/Core/Make.hs @@ -0,0 +1,940 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handy functions for creating much Core syntax +module GHC.Core.Make ( + -- * Constructing normal syntax + mkCoreLet, mkCoreLets, + mkCoreApp, mkCoreApps, mkCoreConApps, + mkCoreLams, mkWildCase, mkIfThenElse, + mkWildValBinder, mkWildEvBinder, + mkSingleAltCase, + sortQuantVars, castBottomExpr, + + -- * Constructing boxed literals + mkWordExpr, mkWordExprWord, + mkIntExpr, mkIntExprInt, + mkIntegerExpr, mkNaturalExpr, + mkFloatExpr, mkDoubleExpr, + mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, + + -- * Floats + FloatBind(..), wrapFloat, wrapFloats, floatBindings, + + -- * Constructing small tuples + mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, + mkCoreTupBoxity, unitExpr, + + -- * Constructing big tuples + mkBigCoreVarTup, mkBigCoreVarTup1, + mkBigCoreVarTupTy, mkBigCoreTupTy, + mkBigCoreTup, + + -- * Deconstructing small tuples + mkSmallTupleSelector, mkSmallTupleCase, + + -- * Deconstructing big tuples + mkTupleSelector, mkTupleSelector1, mkTupleCase, + + -- * Constructing list expressions + mkNilExpr, mkConsExpr, mkListExpr, + mkFoldrExpr, mkBuildExpr, + + -- * Constructing Maybe expressions + mkNothingExpr, mkJustExpr, + + -- * Error Ids + mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, + rEC_CON_ERROR_ID, rUNTIME_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, + tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Id +import Var ( EvVar, setTyVarUnique ) + +import GHC.Core +import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec ) +import Literal +import GHC.Driver.Types + +import TysWiredIn +import PrelNames + +import GHC.Hs.Utils ( mkChunkified, chunkify ) +import Type +import Coercion ( isCoVar ) +import TysPrim +import DataCon ( DataCon, dataConWorkId ) +import IdInfo +import Demand +import Cpr +import Name hiding ( varName ) +import Outputable +import FastString +import UniqSupply +import BasicTypes +import Util +import GHC.Driver.Session +import Data.List + +import Data.Char ( ord ) +import Control.Monad.Fail as MonadFail ( MonadFail ) + +infixl 4 `mkCoreApp`, `mkCoreApps` + +{- +************************************************************************ +* * +\subsection{Basic GHC.Core construction} +* * +************************************************************************ +-} +sortQuantVars :: [Var] -> [Var] +-- Sort the variables, putting type and covars first, in scoped order, +-- and then other Ids +-- It is a deterministic sort, meaining it doesn't look at the values of +-- Uniques. For explanation why it's important See Note [Unique Determinism] +-- in Unique. +sortQuantVars vs = sorted_tcvs ++ ids + where + (tcvs, ids) = partition (isTyVar <||> isCoVar) vs + sorted_tcvs = scopedSort tcvs + +-- | Bind a binding group over an expression, using a @let@ or @case@ as +-- appropriate (see "GHC.Core#let_app_invariant") +mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr +mkCoreLet (NonRec bndr rhs) body -- See Note [Core let/app invariant] + = bindNonRec bndr rhs body +mkCoreLet bind body + = Let bind body + +-- | Create a lambda where the given expression has a number of variables +-- bound over it. The leftmost binder is that bound by the outermost +-- lambda in the result +mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr +mkCoreLams = mkLams + +-- | Bind a list of binding groups over an expression. The leftmost binding +-- group becomes the outermost group in the resulting expression +mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr +mkCoreLets binds body = foldr mkCoreLet body binds + +-- | Construct an expression which represents the application of a number of +-- expressions to that of a data constructor expression. The leftmost expression +-- in the list is applied first +mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr +mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args + +-- | Construct an expression which represents the application of a number of +-- expressions to another. The leftmost expression in the list is applied first +-- Respects the let/app invariant by building a case expression where necessary +-- See Note [Core let/app invariant] in GHC.Core +mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr +mkCoreApps fun args + = fst $ + foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args + where + doc_string = ppr fun_ty $$ ppr fun $$ ppr args + fun_ty = exprType fun + +-- | Construct an expression which represents the application of one expression +-- to the other +-- Respects the let/app invariant by building a case expression where necessary +-- See Note [Core let/app invariant] in GHC.Core +mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr +mkCoreApp s fun arg + = fst $ mkCoreAppTyped s (fun, exprType fun) arg + +-- | Construct an expression which represents the application of one expression +-- paired with its type to an argument. The result is paired with its type. This +-- function is not exported and used in the definition of 'mkCoreApp' and +-- 'mkCoreApps'. +-- Respects the let/app invariant by building a case expression where necessary +-- See Note [Core let/app invariant] in GHC.Core +mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type) +mkCoreAppTyped _ (fun, fun_ty) (Type ty) + = (App fun (Type ty), piResultTy fun_ty ty) +mkCoreAppTyped _ (fun, fun_ty) (Coercion co) + = (App fun (Coercion co), funResultTy fun_ty) +mkCoreAppTyped d (fun, fun_ty) arg + = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d ) + (mkValApp fun arg arg_ty res_ty, res_ty) + where + (arg_ty, res_ty) = splitFunTy fun_ty + +mkValApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr +-- Build an application (e1 e2), +-- or a strict binding (case e2 of x -> e1 x) +-- using the latter when necessary to respect the let/app invariant +-- See Note [Core let/app invariant] in GHC.Core +mkValApp fun arg arg_ty res_ty + | not (needsCaseBinding arg_ty arg) + = App fun arg -- The vastly common case + | otherwise + = mkStrictApp fun arg arg_ty res_ty + +{- ********************************************************************* +* * + Building case expressions +* * +********************************************************************* -} + +mkWildEvBinder :: PredType -> EvVar +mkWildEvBinder pred = mkWildValBinder pred + +-- | Make a /wildcard binder/. This is typically used when you need a binder +-- that you expect to use only at a *binding* site. Do not use it at +-- occurrence sites because it has a single, fixed unique, and it's very +-- easy to get into difficulties with shadowing. That's why it is used so little. +-- See Note [WildCard binders] in SimplEnv +mkWildValBinder :: Type -> Id +mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty + -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors + -- (e.g. see test T15695). Ticket #17291 covers fixing this problem. + +mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr +-- Make a case expression whose case binder is unused +-- The alts and res_ty should not have any occurrences of WildId +mkWildCase scrut scrut_ty res_ty alts + = Case scrut (mkWildValBinder scrut_ty) res_ty alts + +mkStrictApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr +-- Build a strict application (case e2 of x -> e1 x) +mkStrictApp fun arg arg_ty res_ty + = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] + -- mkDefaultCase looks attractive here, and would be sound. + -- But it uses (exprType alt_rhs) to compute the result type, + -- whereas here we already know that the result type is res_ty + where + arg_id = mkWildValBinder arg_ty + -- Lots of shadowing, but it doesn't matter, + -- because 'fun' and 'res_ty' should not have a free wild-id + -- + -- This is Dangerous. But this is the only place we play this + -- game, mkStrictApp returns an expression that does not have + -- a free wild-id. So the only way 'fun' could get a free wild-id + -- would be if you take apart this case expression (or some other + -- expression that uses mkWildValBinder, of which there are not + -- many), and pass a fragment of it as the fun part of a 'mkStrictApp'. + +mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr +mkIfThenElse guard then_expr else_expr +-- Not going to be refining, so okay to take the type of the "then" clause + = mkWildCase guard boolTy (exprType then_expr) + [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! + (DataAlt trueDataCon, [], then_expr) ] + +castBottomExpr :: CoreExpr -> Type -> CoreExpr +-- (castBottomExpr e ty), assuming that 'e' diverges, +-- return an expression of type 'ty' +-- See Note [Empty case alternatives] in GHC.Core +castBottomExpr e res_ty + | e_ty `eqType` res_ty = e + | otherwise = Case e (mkWildValBinder e_ty) res_ty [] + where + e_ty = exprType e + +{- +************************************************************************ +* * +\subsection{Making literals} +* * +************************************************************************ +-} + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@ +mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int +mkIntExpr dflags i = mkCoreConApps intDataCon [mkIntLit dflags i] + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@ +mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int +mkIntExprInt dflags i = mkCoreConApps intDataCon [mkIntLitInt dflags i] + +-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value +mkWordExpr :: DynFlags -> Integer -> CoreExpr +mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w] + +-- | Create a 'CoreExpr' which will evaluate to the given @Word@ +mkWordExprWord :: DynFlags -> Word -> CoreExpr +mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w] + +-- | Create a 'CoreExpr' which will evaluate to the given @Integer@ +mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer +mkIntegerExpr i = do t <- lookupTyCon integerTyConName + return (Lit (mkLitInteger i (mkTyConTy t))) + +-- | Create a 'CoreExpr' which will evaluate to the given @Natural@ +mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr +mkNaturalExpr i = do t <- lookupTyCon naturalTyConName + return (Lit (mkLitNatural i (mkTyConTy t))) + +-- | Create a 'CoreExpr' which will evaluate to the given @Float@ +mkFloatExpr :: Float -> CoreExpr +mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f] + +-- | Create a 'CoreExpr' which will evaluate to the given @Double@ +mkDoubleExpr :: Double -> CoreExpr +mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d] + + +-- | Create a 'CoreExpr' which will evaluate to the given @Char@ +mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int +mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c] + +-- | Create a 'CoreExpr' which will evaluate to the given @String@ +mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String + +-- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@ +mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String + +mkStringExpr str = mkStringExprFS (mkFastString str) + +mkStringExprFS = mkStringExprFSWith lookupId + +mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr +mkStringExprFSWith lookupM str + | nullFS str + = return (mkNilExpr charTy) + + | all safeChar chars + = do unpack_id <- lookupM unpackCStringName + return (App (Var unpack_id) lit) + + | otherwise + = do unpack_utf8_id <- lookupM unpackCStringUtf8Name + return (App (Var unpack_utf8_id) lit) + + where + chars = unpackFS str + safeChar c = ord c >= 1 && ord c <= 0x7F + lit = Lit (LitString (bytesFS str)) + +{- +************************************************************************ +* * +\subsection{Tuple constructors} +* * +************************************************************************ +-} + +{- +Creating tuples and their types for Core expressions + +@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@. + +* If it has only one element, it is the identity function. + +* If there are more elements than a big tuple can have, it nests + the tuples. + +Note [Flattening one-tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This family of functions creates a tuple of variables/expressions/types. + mkCoreTup [e1,e2,e3] = (e1,e2,e3) +What if there is just one variable/expression/type in the argument? +We could do one of two things: + +* Flatten it out, so that + mkCoreTup [e1] = e1 + +* Build a one-tuple (see Note [One-tuples] in TysWiredIn) + mkCoreTup1 [e1] = Unit e1 + We use a suffix "1" to indicate this. + +Usually we want the former, but occasionally the latter. + +NB: The logic in tupleDataCon knows about () and Unit and (,), etc. + +Note [Don't flatten tuples from HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we get an explicit 1-tuple from HsSyn somehow (likely: Template Haskell), +we should treat it really as a 1-tuple, without flattening. Note that a +1-tuple and a flattened value have different performance and laziness +characteristics, so should just do what we're asked. + +This arose from discussions in #16881. + +One-tuples that arise internally depend on the circumstance; often flattening +is a good idea. Decisions are made on a case-by-case basis. + +-} + +-- | Build the type of a small tuple that holds the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreVarTupTy :: [Id] -> Type +mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) + +-- | Build a small tuple holding the specified expressions +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreTup :: [CoreExpr] -> CoreExpr +mkCoreTup [c] = c +mkCoreTup cs = mkCoreTup1 cs -- non-1-tuples are uniform + +-- | Build a small tuple holding the specified expressions +-- One-tuples are *not* flattened; see Note [Flattening one-tuples] +-- See also Note [Don't flatten tuples from HsSyn] +mkCoreTup1 :: [CoreExpr] -> CoreExpr +mkCoreTup1 cs = mkCoreConApps (tupleDataCon Boxed (length cs)) + (map (Type . exprType) cs ++ cs) + +-- | Build a small unboxed tuple holding the specified expressions, +-- with the given types. The types must be the types of the expressions. +-- Do not include the RuntimeRep specifiers; this function calculates them +-- for you. +-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples] +mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr +mkCoreUbxTup tys exps + = ASSERT( tys `equalLength` exps) + mkCoreConApps (tupleDataCon Unboxed (length tys)) + (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) + +-- | Make a core tuple of the given boxity; don't flatten 1-tuples +mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr +mkCoreTupBoxity Boxed exps = mkCoreTup1 exps +mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps + +-- | Build a big tuple holding the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreVarTup :: [Id] -> CoreExpr +mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) + +mkBigCoreVarTup1 :: [Id] -> CoreExpr +-- Same as mkBigCoreVarTup, but one-tuples are NOT flattened +-- see Note [Flattening one-tuples] +mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1) + [Type (idType id), Var id] +mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids) + +-- | Build the type of a big tuple that holds the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreVarTupTy :: [Id] -> Type +mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) + +-- | Build a big tuple holding the specified expressions +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreTup :: [CoreExpr] -> CoreExpr +mkBigCoreTup = mkChunkified mkCoreTup + +-- | Build the type of a big tuple that holds the specified type of thing +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreTupTy :: [Type] -> Type +mkBigCoreTupTy = mkChunkified mkBoxedTupleTy + +-- | The unit expression +unitExpr :: CoreExpr +unitExpr = Var unitDataConId + +{- +************************************************************************ +* * +\subsection{Tuple destructors} +* * +************************************************************************ +-} + +-- | Builds a selector which scrutises the given +-- expression and extracts the one name from the list given. +-- If you want the no-shadowing rule to apply, the caller +-- is responsible for making sure that none of these names +-- are in scope. +-- +-- If there is just one 'Id' in the tuple, then the selector is +-- just the identity. +-- +-- If necessary, we pattern match on a \"big\" tuple. +mkTupleSelector, mkTupleSelector1 + :: [Id] -- ^ The 'Id's to pattern match the tuple against + -> Id -- ^ The 'Id' to select + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr -- ^ Selector expression + +-- mkTupleSelector [a,b,c,d] b v e +-- = case e of v { +-- (p,q) -> case p of p { +-- (a,b) -> b }} +-- We use 'tpl' vars for the p,q, since shadowing does not matter. +-- +-- In fact, it's more convenient to generate it innermost first, getting +-- +-- case (case e of v +-- (p,q) -> p) of p +-- (a,b) -> b +mkTupleSelector vars the_var scrut_var scrut + = mk_tup_sel (chunkify vars) the_var + where + mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut + mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $ + mk_tup_sel (chunkify tpl_vs) tpl_v + where + tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] + tpl_vs = mkTemplateLocals tpl_tys + [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, + the_var `elem` gp ] +-- ^ 'mkTupleSelector1' is like 'mkTupleSelector' +-- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) +mkTupleSelector1 vars the_var scrut_var scrut + | [_] <- vars + = mkSmallTupleSelector1 vars the_var scrut_var scrut + | otherwise + = mkTupleSelector vars the_var scrut_var scrut + +-- | Like 'mkTupleSelector' but for tuples that are guaranteed +-- never to be \"big\". +-- +-- > mkSmallTupleSelector [x] x v e = [| e |] +-- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |] +mkSmallTupleSelector, mkSmallTupleSelector1 + :: [Id] -- The tuple args + -> Id -- The selected one + -> Id -- A variable of the same type as the scrutinee + -> CoreExpr -- Scrutinee + -> CoreExpr +mkSmallTupleSelector [var] should_be_the_same_var _ scrut + = ASSERT(var == should_be_the_same_var) + scrut -- Special case for 1-tuples +mkSmallTupleSelector vars the_var scrut_var scrut + = mkSmallTupleSelector1 vars the_var scrut_var scrut + +-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector' +-- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) +mkSmallTupleSelector1 vars the_var scrut_var scrut + = ASSERT( notNull vars ) + Case scrut scrut_var (idType the_var) + [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)] + +-- | A generalization of 'mkTupleSelector', allowing the body +-- of the case to be an arbitrary expression. +-- +-- To avoid shadowing, we use uniques to invent new variables. +-- +-- If necessary we pattern match on a \"big\" tuple. +mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables + -> [Id] -- ^ The tuple identifiers to pattern match on + -> CoreExpr -- ^ Body of the case + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr +-- ToDo: eliminate cases where none of the variables are needed. +-- +-- mkTupleCase uniqs [a,b,c,d] body v e +-- = case e of v { (p,q) -> +-- case p of p { (a,b) -> +-- case q of q { (c,d) -> +-- body }}} +mkTupleCase uniqs vars body scrut_var scrut + = mk_tuple_case uniqs (chunkify vars) body + where + -- This is the case where don't need any nesting + mk_tuple_case _ [vars] body + = mkSmallTupleCase vars body scrut_var scrut + + -- This is the case where we must make nest tuples at least once + mk_tuple_case us vars_s body + = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s + in mk_tuple_case us' (chunkify vars') body' + + one_tuple_case chunk_vars (us, vs, body) + = let (uniq, us') = takeUniqFromSupply us + scrut_var = mkSysLocal (fsLit "ds") uniq + (mkBoxedTupleTy (map idType chunk_vars)) + body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) + in (us', scrut_var:vs, body') + +-- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed +-- not to need nesting. +mkSmallTupleCase + :: [Id] -- ^ The tuple args + -> CoreExpr -- ^ Body of the case + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr + +mkSmallTupleCase [var] body _scrut_var scrut + = bindNonRec var scrut body +mkSmallTupleCase vars body scrut_var scrut +-- One branch no refinement? + = Case scrut scrut_var (exprType body) + [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)] + +{- +************************************************************************ +* * + Floats +* * +************************************************************************ +-} + +data FloatBind + = FloatLet CoreBind + | FloatCase CoreExpr Id AltCon [Var] + -- case e of y { C ys -> ... } + -- See Note [Floating single-alternative cases] in SetLevels + +instance Outputable FloatBind where + ppr (FloatLet b) = text "LET" <+> ppr b + ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b) + 2 (ppr c <+> ppr bs) + +wrapFloat :: FloatBind -> CoreExpr -> CoreExpr +wrapFloat (FloatLet defns) body = Let defns body +wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body + +-- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn] +-- u = let b1 in let b2 in … in let bn in u@ +wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr +wrapFloats floats expr = foldr wrapFloat expr floats + +bindBindings :: CoreBind -> [Var] +bindBindings (NonRec b _) = [b] +bindBindings (Rec bnds) = map fst bnds + +floatBindings :: FloatBind -> [Var] +floatBindings (FloatLet bnd) = bindBindings bnd +floatBindings (FloatCase _ b _ bs) = b:bs + +{- +************************************************************************ +* * +\subsection{Common list manipulation expressions} +* * +************************************************************************ + +Call the constructor Ids when building explicit lists, so that they +interact well with rules. +-} + +-- | Makes a list @[]@ for lists of the specified type +mkNilExpr :: Type -> CoreExpr +mkNilExpr ty = mkCoreConApps nilDataCon [Type ty] + +-- | Makes a list @(:)@ for lists of the specified type +mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr +mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl] + +-- | Make a list containing the given expressions, where the list has the given type +mkListExpr :: Type -> [CoreExpr] -> CoreExpr +mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs + +-- | Make a fully applied 'foldr' expression +mkFoldrExpr :: MonadThings m + => Type -- ^ Element type of the list + -> Type -- ^ Fold result type + -> CoreExpr -- ^ "Cons" function expression for the fold + -> CoreExpr -- ^ "Nil" expression for the fold + -> CoreExpr -- ^ List expression being folded acress + -> m CoreExpr +mkFoldrExpr elt_ty result_ty c n list = do + foldr_id <- lookupId foldrName + return (Var foldr_id `App` Type elt_ty + `App` Type result_ty + `App` c + `App` n + `App` list) + +-- | Make a 'build' expression applied to a locally-bound worker function +mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m) + => Type -- ^ Type of list elements to be built + -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's + -- of the binders for the build worker function, returns + -- the body of that worker + -> m CoreExpr +mkBuildExpr elt_ty mk_build_inside = do + [n_tyvar] <- newTyVars [alphaTyVar] + let n_ty = mkTyVarTy n_tyvar + c_ty = mkVisFunTys [elt_ty, n_ty] n_ty + [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty] + + build_inside <- mk_build_inside (c, c_ty) (n, n_ty) + + build_id <- lookupId buildName + return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside + where + newTyVars tyvar_tmpls = do + uniqs <- getUniquesM + return (zipWith setTyVarUnique tyvar_tmpls uniqs) + +{- +************************************************************************ +* * + Manipulating Maybe data type +* * +************************************************************************ +-} + + +-- | Makes a Nothing for the specified type +mkNothingExpr :: Type -> CoreExpr +mkNothingExpr ty = mkConApp nothingDataCon [Type ty] + +-- | Makes a Just from a value of the specified type +mkJustExpr :: Type -> CoreExpr -> CoreExpr +mkJustExpr ty val = mkConApp justDataCon [Type ty, val] + + +{- +************************************************************************ +* * + Error expressions +* * +************************************************************************ +-} + +mkRuntimeErrorApp + :: Id -- Should be of type (forall a. Addr# -> a) + -- where Addr# points to a UTF8 encoded string + -> Type -- The type to instantiate 'a' + -> String -- The string to print + -> CoreExpr + +mkRuntimeErrorApp err_id res_ty err_msg + = mkApps (Var err_id) [ Type (getRuntimeRep res_ty) + , Type res_ty, err_string ] + where + err_string = Lit (mkLitString err_msg) + +mkImpossibleExpr :: Type -> CoreExpr +mkImpossibleExpr res_ty + = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" + +{- +************************************************************************ +* * + Error Ids +* * +************************************************************************ + +GHC randomly injects these into the code. + +@patError@ is just a version of @error@ for pattern-matching +failures. It knows various ``codes'' which expand to longer +strings---this saves space! + +@absentErr@ is a thing we put in for ``absent'' arguments. They jolly +well shouldn't be yanked on, but if one is, then you will get a +friendly message from @absentErr@ (rather than a totally random +crash). + +@parError@ is a special version of @error@ which the compiler does +not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ +templates, but we don't ever expect to generate code for it. +-} + +errorIds :: [Id] +errorIds + = [ rUNTIME_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, + nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, + rEC_CON_ERROR_ID, + rEC_SEL_ERROR_ID, + aBSENT_ERROR_ID, + tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284 + ] + +recSelErrorName, runtimeErrorName, absentErrorName :: Name +recConErrorName, patErrorName :: Name +nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name +typeErrorName :: Name +absentSumFieldErrorName :: Name + +recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID +absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID +absentSumFieldErrorName = err_nm "absentSumFieldError" absentSumFieldErrorIdKey + aBSENT_SUM_FIELD_ERROR_ID +runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID +recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID +typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID + +noMethodBindingErrorName = err_nm "noMethodBindingError" + noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID +nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError" + nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID + +err_nm :: String -> Unique -> Id -> Name +err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id + +rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id +pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id +tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id +rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName +rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName +rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName +pAT_ERROR_ID = mkRuntimeErrorId patErrorName +nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName +nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName +tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName + +-- Note [aBSENT_SUM_FIELD_ERROR_ID] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Absent argument error for unused unboxed sum fields are different than absent +-- error used in dummy worker functions (see `mkAbsentErrorApp`): +-- +-- - `absentSumFieldError` can't take arguments because it's used in unarise for +-- unused pointer fields in unboxed sums, and applying an argument would +-- require allocating a thunk. +-- +-- - `absentSumFieldError` can't be CAFFY because that would mean making some +-- non-CAFFY definitions that use unboxed sums CAFFY in unarise. +-- +-- To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in +-- RtsStartup.c and mark it as non-CAFFY here. +-- +-- Getting this wrong causes hard-to-debug runtime issues, see #15038. +-- +-- TODO: Remove stable pointer hack after fixing #9718. +-- However, we should still be careful about not making things CAFFY just +-- because they use unboxed sums. Unboxed objects are supposed to be +-- efficient, and none of the other unboxed literals make things CAFFY. + +aBSENT_SUM_FIELD_ERROR_ID + = mkVanillaGlobalWithInfo absentSumFieldErrorName + (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a + (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botDiv + `setCprInfo` mkCprSig 0 botCpr + `setArityInfo` 0 + `setCafInfo` NoCafRefs) -- #15038 + +mkRuntimeErrorId :: Name -> Id +-- Error function +-- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a +-- with arity: 1 +-- which diverges after being given one argument +-- The Addr# is expected to be the address of +-- a UTF8-encoded error string +mkRuntimeErrorId name + = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info + where + bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig + `setCprInfo` mkCprSig 1 botCpr + `setArityInfo` 1 + -- Make arity and strictness agree + + -- Do *not* mark them as NoCafRefs, because they can indeed have + -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, + -- which has some CAFs + -- In due course we may arrange that these error-y things are + -- regarded by the GC as permanently live, in which case we + -- can give them NoCaf info. As it is, any function that calls + -- any pc_bottoming_Id will itself have CafRefs, which bloats + -- SRTs. + + strict_sig = mkClosedStrictSig [evalDmd] botDiv + +runtimeErrorTy :: Type +-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a +-- See Note [Error and friends have an "open-tyvar" forall] +runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] + (mkVisFunTy addrPrimTy openAlphaTy) + +{- Note [Error and friends have an "open-tyvar" forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'error' and 'undefined' have types + error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a + undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a +Notice the runtime-representation polymorphism. This ensures that +"error" can be instantiated at unboxed as well as boxed types. +This is OK because it never returns, so the return type is irrelevant. + + +************************************************************************ +* * + aBSENT_ERROR_ID +* * +************************************************************************ + +Note [aBSENT_ERROR_ID] +~~~~~~~~~~~~~~~~~~~~~~ +We use aBSENT_ERROR_ID to build dummy values in workers. E.g. + + f x = (case x of (a,b) -> b) + 1::Int + +The demand analyser figures ot that only the second component of x is +used, and does a w/w split thus + + f x = case x of (a,b) -> $wf b + + $wf b = let a = absentError "blah" + x = (a,b) + in <the original RHS of f> + +After some simplification, the (absentError "blah") thunk goes away. + +------ Tricky wrinkle ------- +#14285 had, roughly + + data T a = MkT a !a + {-# INLINABLE f #-} + f x = case x of MkT a b -> g (MkT b a) + +It turned out that g didn't use the second component, and hence f doesn't use +the first. But the stable-unfolding for f looks like + \x. case x of MkT a b -> g ($WMkT b a) +where $WMkT is the wrapper for MkT that evaluates its arguments. We +apply the same w/w split to this unfolding (see Note [Worker-wrapper +for INLINEABLE functions] in WorkWrap) so the template ends up like + \b. let a = absentError "blah" + x = MkT a b + in case x of MkT a b -> g ($WMkT b a) + +After doing case-of-known-constructor, and expanding $WMkT we get + \b -> g (case absentError "blah" of a -> MkT b a) + +Yikes! That bogusly appears to evaluate the absentError! + +This is extremely tiresome. Another way to think of this is that, in +Core, it is an invariant that a strict data constructor, like MkT, must +be applied only to an argument in HNF. So (absentError "blah") had +better be non-bottom. + +So the "solution" is to add a special case for absentError to exprIsHNFlike. +This allows Simplify.rebuildCase, in the Note [Case to let transformation] +branch, to convert the case on absentError into a let. We also make +absentError *not* be diverging, unlike the other error-ids, so that we +can be sure not to remove the case branches before converting the case to +a let. + +If, by some bug or bizarre happenstance, we ever call absentError, we should +throw an exception. This should never happen, of course, but we definitely +can't return anything. e.g. if somehow we had + case absentError "foo" of + Nothing -> ... + Just x -> ... +then if we return, the case expression will select a field and continue. +Seg fault city. Better to throw an exception. (Even though we've said +it is in HNF :-) + +It might seem a bit surprising that seq on absentError is simply erased + + absentError "foo" `seq` x ==> x + +but that should be okay; since there's no pattern match we can't really +be relying on anything from it. +-} + +aBSENT_ERROR_ID + = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info + where + absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy addrPrimTy alphaTy) + -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for + -- lifted-type things; see Note [Absent errors] in WwLib + arity_info = vanillaIdInfo `setArityInfo` 1 + -- NB: no bottoming strictness info, unlike other error-ids. + -- See Note [aBSENT_ERROR_ID] + +mkAbsentErrorApp :: Type -- The type to instantiate 'a' + -> String -- The string to print + -> CoreExpr + +mkAbsentErrorApp res_ty err_msg + = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ] + where + err_string = Lit (mkLitString err_msg) diff --git a/compiler/GHC/Core/Map.hs b/compiler/GHC/Core/Map.hs new file mode 100644 index 0000000000..ee12bdd8a3 --- /dev/null +++ b/compiler/GHC/Core/Map.hs @@ -0,0 +1,803 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHC.Core.Map ( + -- * Maps over Core expressions + CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, + -- * Maps over 'Type's + TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, + LooseTypeMap, + -- ** With explicit scoping + CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope, + mkDeBruijnContext, + -- * Maps over 'Maybe' values + MaybeMap, + -- * Maps over 'List' values + ListMap, + -- * Maps over 'Literal's + LiteralMap, + -- * Map for compressing leaves. See Note [Compressed TrieMap] + GenMap, + -- * 'TrieMap' class + TrieMap(..), insertTM, deleteTM, + lkDFreeVar, xtDFreeVar, + lkDNamed, xtDNamed, + (>.>), (|>), (|>>), + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TrieMap +import GHC.Core +import Coercion +import Name +import Type +import TyCoRep +import Var +import FastString(FastString) +import Util + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import VarEnv +import NameEnv +import Outputable +import Control.Monad( (>=>) ) + +{- +This module implements TrieMaps over Core related data structures +like CoreExpr or Type. It is built on the Tries from the TrieMap +module. + +The code is very regular and boilerplate-like, but there is +some neat handling of *binders*. In effect they are deBruijn +numbered on the fly. + + +-} + +---------------------- +-- Recall that +-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c + +-- NB: Be careful about RULES and type families (#5821). So we should make sure +-- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form) + +-- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not +-- known when defining GenMap so we can only specialize them here. + +{-# SPECIALIZE lkG :: Key TypeMapX -> TypeMapG a -> Maybe a #-} +{-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-} +{-# SPECIALIZE lkG :: Key CoreMapX -> CoreMapG a -> Maybe a #-} + + +{-# SPECIALIZE xtG :: Key TypeMapX -> XT a -> TypeMapG a -> TypeMapG a #-} +{-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-} +{-# SPECIALIZE xtG :: Key CoreMapX -> XT a -> CoreMapG a -> CoreMapG a #-} + +{-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a -> TypeMapG b #-} +{-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-} +{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a -> CoreMapG b #-} + +{-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a -> b -> b #-} +{-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-} +{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a -> b -> b #-} + + +{- +************************************************************************ +* * + CoreMap +* * +************************************************************************ +-} + +lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a +lkDNamed n env = lookupDNameEnv env (getName n) + +xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a +xtDNamed tc f m = alterDNameEnv f m (getName tc) + + +{- +Note [Binders] +~~~~~~~~~~~~~~ + * In general we check binders as late as possible because types are + less likely to differ than expression structure. That's why + cm_lam :: CoreMapG (TypeMapG a) + rather than + cm_lam :: TypeMapG (CoreMapG a) + + * We don't need to look at the type of some binders, notably + - the case binder in (Case _ b _ _) + - the binders in an alternative + because they are totally fixed by the context + +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* For a key (Case e b ty (alt:alts)) we don't need to look the return type + 'ty', because every alternative has that type. + +* For a key (Case e b ty []) we MUST look at the return type 'ty', because + otherwise (Case (error () "urk") _ Int []) would compare equal to + (Case (error () "urk") _ Bool []) + which is utterly wrong (#6097) + +We could compare the return type regardless, but the wildly common case +is that it's unnecessary, so we have two fields (cm_case and cm_ecase) +for the two possibilities. Only cm_ecase looks at the type. + +See also Note [Empty case alternatives] in GHC.Core. +-} + +-- | @CoreMap a@ is a map from 'CoreExpr' to @a@. If you are a client, this +-- is the type you want. +newtype CoreMap a = CoreMap (CoreMapG a) + +instance TrieMap CoreMap where + type Key CoreMap = CoreExpr + emptyTM = CoreMap emptyTM + lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m + alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m) + foldTM k (CoreMap m) = foldTM k m + mapTM f (CoreMap m) = CoreMap (mapTM f m) + +-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended +-- key makes it suitable for recursive traversal, since it can track binders, +-- but it is strictly internal to this module. If you are including a 'CoreMap' +-- inside another 'TrieMap', this is the type you want. +type CoreMapG = GenMap CoreMapX + +-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without +-- the 'GenMap' optimization. +data CoreMapX a + = CM { cm_var :: VarMap a + , cm_lit :: LiteralMap a + , cm_co :: CoercionMapG a + , cm_type :: TypeMapG a + , cm_cast :: CoreMapG (CoercionMapG a) + , cm_tick :: CoreMapG (TickishMap a) + , cm_app :: CoreMapG (CoreMapG a) + , cm_lam :: CoreMapG (BndrMap a) -- Note [Binders] + , cm_letn :: CoreMapG (CoreMapG (BndrMap a)) + , cm_letr :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a)) + , cm_case :: CoreMapG (ListMap AltMap a) + , cm_ecase :: CoreMapG (TypeMapG a) -- Note [Empty case alternatives] + } + +instance Eq (DeBruijn CoreExpr) where + D env1 e1 == D env2 e2 = go e1 e2 where + go (Var v1) (Var v2) = case (lookupCME env1 v1, lookupCME env2 v2) of + (Just b1, Just b2) -> b1 == b2 + (Nothing, Nothing) -> v1 == v2 + _ -> False + go (Lit lit1) (Lit lit2) = lit1 == lit2 + go (Type t1) (Type t2) = D env1 t1 == D env2 t2 + go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2 + go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2 + go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2 + -- This seems a bit dodgy, see 'eqTickish' + go (Tick n1 e1) (Tick n2 e2) = n1 == n2 && go e1 e2 + + go (Lam b1 e1) (Lam b2 e2) + = D env1 (varType b1) == D env2 (varType b2) + && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2 + + go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) + = go r1 r2 + && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2 + + go (Let (Rec ps1) e1) (Let (Rec ps2) e2) + = equalLength ps1 ps2 + && D env1' rs1 == D env2' rs2 + && D env1' e1 == D env2' e2 + where + (bs1,rs1) = unzip ps1 + (bs2,rs2) = unzip ps2 + env1' = extendCMEs env1 bs1 + env2' = extendCMEs env2 bs2 + + go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | null a1 -- See Note [Empty case alternatives] + = null a2 && go e1 e2 && D env1 t1 == D env2 t2 + | otherwise + = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2 + + go _ _ = False + +emptyE :: CoreMapX a +emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM + , cm_co = emptyTM, cm_type = emptyTM + , cm_cast = emptyTM, cm_app = emptyTM + , cm_lam = emptyTM, cm_letn = emptyTM + , cm_letr = emptyTM, cm_case = emptyTM + , cm_ecase = emptyTM, cm_tick = emptyTM } + +instance TrieMap CoreMapX where + type Key CoreMapX = DeBruijn CoreExpr + emptyTM = emptyE + lookupTM = lkE + alterTM = xtE + foldTM = fdE + mapTM = mapE + +-------------------------- +mapE :: (a->b) -> CoreMapX a -> CoreMapX b +mapE f (CM { cm_var = cvar, cm_lit = clit + , cm_co = cco, cm_type = ctype + , cm_cast = ccast , cm_app = capp + , cm_lam = clam, cm_letn = cletn + , cm_letr = cletr, cm_case = ccase + , cm_ecase = cecase, cm_tick = ctick }) + = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit + , cm_co = mapTM f cco, cm_type = mapTM f ctype + , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp + , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn + , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase + , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick } + +-------------------------- +lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a +lookupCoreMap cm e = lookupTM e cm + +extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a +extendCoreMap m e v = alterTM e (\_ -> Just v) m + +foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b +foldCoreMap k z m = foldTM k m z + +emptyCoreMap :: CoreMap a +emptyCoreMap = emptyTM + +instance Outputable a => Outputable (CoreMap a) where + ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m []) + +------------------------- +fdE :: (a -> b -> b) -> CoreMapX a -> b -> b +fdE k m + = foldTM k (cm_var m) + . foldTM k (cm_lit m) + . foldTM k (cm_co m) + . foldTM k (cm_type m) + . foldTM (foldTM k) (cm_cast m) + . foldTM (foldTM k) (cm_tick m) + . foldTM (foldTM k) (cm_app m) + . foldTM (foldTM k) (cm_lam m) + . foldTM (foldTM (foldTM k)) (cm_letn m) + . foldTM (foldTM (foldTM k)) (cm_letr m) + . foldTM (foldTM k) (cm_case m) + . foldTM (foldTM k) (cm_ecase m) + +-- lkE: lookup in trie for expressions +lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a +lkE (D env expr) cm = go expr cm + where + go (Var v) = cm_var >.> lkVar env v + go (Lit l) = cm_lit >.> lookupTM l + go (Type t) = cm_type >.> lkG (D env t) + go (Coercion c) = cm_co >.> lkG (D env c) + go (Cast e c) = cm_cast >.> lkG (D env e) >=> lkG (D env c) + go (Tick tickish e) = cm_tick >.> lkG (D env e) >=> lkTickish tickish + go (App e1 e2) = cm_app >.> lkG (D env e2) >=> lkG (D env e1) + go (Lam v e) = cm_lam >.> lkG (D (extendCME env v) e) + >=> lkBndr env v + go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r) + >=> lkG (D (extendCME env b) e) >=> lkBndr env b + go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr + >.> lkList (lkG . D env1) rhss + >=> lkG (D env1 e) + >=> lkList (lkBndr env1) bndrs + go (Case e b ty as) -- See Note [Empty case alternatives] + | null as = cm_ecase >.> lkG (D env e) >=> lkG (D env ty) + | otherwise = cm_case >.> lkG (D env e) + >=> lkList (lkA (extendCME env b)) as + +xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a +xtE (D env (Var v)) f m = m { cm_var = cm_var m + |> xtVar env v f } +xtE (D env (Type t)) f m = m { cm_type = cm_type m + |> xtG (D env t) f } +xtE (D env (Coercion c)) f m = m { cm_co = cm_co m + |> xtG (D env c) f } +xtE (D _ (Lit l)) f m = m { cm_lit = cm_lit m |> alterTM l f } +xtE (D env (Cast e c)) f m = m { cm_cast = cm_cast m |> xtG (D env e) + |>> xtG (D env c) f } +xtE (D env (Tick t e)) f m = m { cm_tick = cm_tick m |> xtG (D env e) + |>> xtTickish t f } +xtE (D env (App e1 e2)) f m = m { cm_app = cm_app m |> xtG (D env e2) + |>> xtG (D env e1) f } +xtE (D env (Lam v e)) f m = m { cm_lam = cm_lam m + |> xtG (D (extendCME env v) e) + |>> xtBndr env v f } +xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m + |> xtG (D (extendCME env b) e) + |>> xtG (D env r) + |>> xtBndr env b f } +xtE (D env (Let (Rec prs) e)) f m = m { cm_letr = + let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr m + |> xtList (xtG . D env1) rhss + |>> xtG (D env1 e) + |>> xtList (xtBndr env1) + bndrs f } +xtE (D env (Case e b ty as)) f m + | null as = m { cm_ecase = cm_ecase m |> xtG (D env e) + |>> xtG (D env ty) f } + | otherwise = m { cm_case = cm_case m |> xtG (D env e) + |>> let env1 = extendCME env b + in xtList (xtA env1) as f } + +-- TODO: this seems a bit dodgy, see 'eqTickish' +type TickishMap a = Map.Map (Tickish Id) a +lkTickish :: Tickish Id -> TickishMap a -> Maybe a +lkTickish = lookupTM + +xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a +xtTickish = alterTM + +------------------------ +data AltMap a -- A single alternative + = AM { am_deflt :: CoreMapG a + , am_data :: DNameEnv (CoreMapG a) + , am_lit :: LiteralMap (CoreMapG a) } + +instance TrieMap AltMap where + type Key AltMap = CoreAlt + emptyTM = AM { am_deflt = emptyTM + , am_data = emptyDNameEnv + , am_lit = emptyTM } + lookupTM = lkA emptyCME + alterTM = xtA emptyCME + foldTM = fdA + mapTM = mapA + +instance Eq (DeBruijn CoreAlt) where + D env1 a1 == D env2 a2 = go a1 a2 where + go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2) + = D env1 rhs1 == D env2 rhs2 + go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2) + = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 + go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2) + = dc1 == dc2 && + D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 + go _ _ = False + +mapA :: (a->b) -> AltMap a -> AltMap b +mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) + = AM { am_deflt = mapTM f adeflt + , am_data = mapTM (mapTM f) adata + , am_lit = mapTM (mapTM f) alit } + +lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a +lkA env (DEFAULT, _, rhs) = am_deflt >.> lkG (D env rhs) +lkA env (LitAlt lit, _, rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) +lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc + >=> lkG (D (extendCMEs env bs) rhs) + +xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a +xtA env (DEFAULT, _, rhs) f m = + m { am_deflt = am_deflt m |> xtG (D env rhs) f } +xtA env (LitAlt l, _, rhs) f m = + m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f } +xtA env (DataAlt d, bs, rhs) f m = + m { am_data = am_data m |> xtDNamed d + |>> xtG (D (extendCMEs env bs) rhs) f } + +fdA :: (a -> b -> b) -> AltMap a -> b -> b +fdA k m = foldTM k (am_deflt m) + . foldTM (foldTM k) (am_data m) + . foldTM (foldTM k) (am_lit m) + +{- +************************************************************************ +* * + Coercions +* * +************************************************************************ +-} + +-- We should really never care about the contents of a coercion. Instead, +-- just look up the coercion's type. +newtype CoercionMap a = CoercionMap (CoercionMapG a) + +instance TrieMap CoercionMap where + type Key CoercionMap = Coercion + emptyTM = CoercionMap emptyTM + lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m + alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) + foldTM k (CoercionMap m) = foldTM k m + mapTM f (CoercionMap m) = CoercionMap (mapTM f m) + +type CoercionMapG = GenMap CoercionMapX +newtype CoercionMapX a = CoercionMapX (TypeMapX a) + +instance TrieMap CoercionMapX where + type Key CoercionMapX = DeBruijn Coercion + emptyTM = CoercionMapX emptyTM + lookupTM = lkC + alterTM = xtC + foldTM f (CoercionMapX core_tm) = foldTM f core_tm + mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm) + +instance Eq (DeBruijn Coercion) where + D env1 co1 == D env2 co2 + = D env1 (coercionType co1) == + D env2 (coercionType co2) + +lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a +lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co) + core_tm + +xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a +xtC (D env co) f (CoercionMapX m) + = CoercionMapX (xtT (D env $ coercionType co) f m) + +{- +************************************************************************ +* * + Types +* * +************************************************************************ +-} + +-- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@. The extended +-- key makes it suitable for recursive traversal, since it can track binders, +-- but it is strictly internal to this module. If you are including a 'TypeMap' +-- inside another 'TrieMap', this is the type you want. Note that this +-- lookup does not do a kind-check. Thus, all keys in this map must have +-- the same kind. Also note that this map respects the distinction between +-- @Type@ and @Constraint@, despite the fact that they are equivalent type +-- synonyms in Core. +type TypeMapG = GenMap TypeMapX + +-- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the +-- 'GenMap' optimization. +data TypeMapX a + = TM { tm_var :: VarMap a + , tm_app :: TypeMapG (TypeMapG a) + , tm_tycon :: DNameEnv a + , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] + , tm_tylit :: TyLitMap a + , tm_coerce :: Maybe a + } + -- Note that there is no tyconapp case; see Note [Equality on AppTys] in Type + +-- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the +-- last one? See Note [Equality on AppTys] in Type +-- +-- Note, however, that we keep Constraint and Type apart here, despite the fact +-- that they are both synonyms of TYPE 'LiftedRep (see #11715). +trieMapView :: Type -> Maybe Type +trieMapView ty + -- First check for TyConApps that need to be expanded to + -- AppTy chains. + | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty + = Just $ foldl' AppTy (TyConApp tc []) tys + + -- Then resolve any remaining nullary synonyms. + | Just ty' <- tcView ty = Just ty' +trieMapView _ = Nothing + +instance TrieMap TypeMapX where + type Key TypeMapX = DeBruijn Type + emptyTM = emptyT + lookupTM = lkT + alterTM = xtT + foldTM = fdT + mapTM = mapT + +instance Eq (DeBruijn Type) where + env_t@(D env t) == env_t'@(D env' t') + | Just new_t <- tcView t = D env new_t == env_t' + | Just new_t' <- tcView t' = env_t == D env' new_t' + | otherwise + = case (t, t') of + (CastTy t1 _, _) -> D env t1 == D env t' + (_, CastTy t1' _) -> D env t == D env t1' + + (TyVarTy v, TyVarTy v') + -> case (lookupCME env v, lookupCME env' v') of + (Just bv, Just bv') -> bv == bv' + (Nothing, Nothing) -> v == v' + _ -> False + -- See Note [Equality on AppTys] in Type + (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s + -> D env t1 == D env' t1' && D env t2 == D env' t2' + (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s + -> D env t1 == D env' t1' && D env t2 == D env' t2' + (FunTy _ t1 t2, FunTy _ t1' t2') + -> D env t1 == D env' t1' && D env t2 == D env' t2' + (TyConApp tc tys, TyConApp tc' tys') + -> tc == tc' && D env tys == D env' tys' + (LitTy l, LitTy l') + -> l == l' + (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty') + -> D env (varType tv) == D env' (varType tv') && + D (extendCME env tv) ty == D (extendCME env' tv') ty' + (CoercionTy {}, CoercionTy {}) + -> True + _ -> False + +instance {-# OVERLAPPING #-} + Outputable a => Outputable (TypeMapG a) where + ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m []) + +emptyT :: TypeMapX a +emptyT = TM { tm_var = emptyTM + , tm_app = emptyTM + , tm_tycon = emptyDNameEnv + , tm_forall = emptyTM + , tm_tylit = emptyTyLitMap + , tm_coerce = Nothing } + +mapT :: (a->b) -> TypeMapX a -> TypeMapX b +mapT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon + , tm_forall = tforall, tm_tylit = tlit + , tm_coerce = tcoerce }) + = TM { tm_var = mapTM f tvar + , tm_app = mapTM (mapTM f) tapp + , tm_tycon = mapTM f ttycon + , tm_forall = mapTM (mapTM f) tforall + , tm_tylit = mapTM f tlit + , tm_coerce = fmap f tcoerce } + +----------------- +lkT :: DeBruijn Type -> TypeMapX a -> Maybe a +lkT (D env ty) m = go ty m + where + go ty | Just ty' <- trieMapView ty = go ty' + go (TyVarTy v) = tm_var >.> lkVar env v + go (AppTy t1 t2) = tm_app >.> lkG (D env t1) + >=> lkG (D env t2) + go (TyConApp tc []) = tm_tycon >.> lkDNamed tc + go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) + go (LitTy l) = tm_tylit >.> lkTyLit l + go (ForAllTy (Bndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) + >=> lkBndr env tv + go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) + go (CastTy t _) = go t + go (CoercionTy {}) = tm_coerce + +----------------- +xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a +xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m + +xtT (D env (TyVarTy v)) f m = m { tm_var = tm_var m |> xtVar env v f } +xtT (D env (AppTy t1 t2)) f m = m { tm_app = tm_app m |> xtG (D env t1) + |>> xtG (D env t2) f } +xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f } +xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } +xtT (D env (CastTy t _)) f m = xtT (D env t) f m +xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } +xtT (D env (ForAllTy (Bndr tv _) ty)) f m + = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty) + |>> xtBndr env tv f } +xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) +xtT (D _ ty@(FunTy {})) _ _ = pprPanic "xtT FunTy" (ppr ty) + +fdT :: (a -> b -> b) -> TypeMapX a -> b -> b +fdT k m = foldTM k (tm_var m) + . foldTM (foldTM k) (tm_app m) + . foldTM k (tm_tycon m) + . foldTM (foldTM k) (tm_forall m) + . foldTyLit k (tm_tylit m) + . foldMaybe k (tm_coerce m) + +------------------------ +data TyLitMap a = TLM { tlm_number :: Map.Map Integer a + , tlm_string :: Map.Map FastString a + } + +instance TrieMap TyLitMap where + type Key TyLitMap = TyLit + emptyTM = emptyTyLitMap + lookupTM = lkTyLit + alterTM = xtTyLit + foldTM = foldTyLit + mapTM = mapTyLit + +emptyTyLitMap :: TyLitMap a +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty } + +mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b +mapTyLit f (TLM { tlm_number = tn, tlm_string = ts }) + = TLM { tlm_number = Map.map f tn, tlm_string = Map.map f ts } + +lkTyLit :: TyLit -> TyLitMap a -> Maybe a +lkTyLit l = + case l of + NumTyLit n -> tlm_number >.> Map.lookup n + StrTyLit n -> tlm_string >.> Map.lookup n + +xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a +xtTyLit l f m = + case l of + NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n } + StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n } + +foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b +foldTyLit l m = flip (Map.foldr l) (tlm_string m) + . flip (Map.foldr l) (tlm_number m) + +------------------------------------------------- +-- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this +-- is the type you want. The keys in this map may have different kinds. +newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a)) + +lkTT :: DeBruijn Type -> TypeMap a -> Maybe a +lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m + >>= lkG (D env ty) + +xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a +xtTT (D env ty) f (TypeMap m) + = TypeMap (m |> xtG (D env $ typeKind ty) + |>> xtG (D env ty) f) + +-- Below are some client-oriented functions which operate on 'TypeMap'. + +instance TrieMap TypeMap where + type Key TypeMap = Type + emptyTM = TypeMap emptyTM + lookupTM k m = lkTT (deBruijnize k) m + alterTM k f m = xtTT (deBruijnize k) f m + foldTM k (TypeMap m) = foldTM (foldTM k) m + mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m) + +foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b +foldTypeMap k z m = foldTM k m z + +emptyTypeMap :: TypeMap a +emptyTypeMap = emptyTM + +lookupTypeMap :: TypeMap a -> Type -> Maybe a +lookupTypeMap cm t = lookupTM t cm + +extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a +extendTypeMap m t v = alterTM t (const (Just v)) m + +lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a +lookupTypeMapWithScope m cm t = lkTT (D cm t) m + +-- | Extend a 'TypeMap' with a type in the given context. +-- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to +-- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over +-- multiple insertions. +extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a +extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m + +-- | Construct a deBruijn environment with the given variables in scope. +-- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@ +mkDeBruijnContext :: [Var] -> CmEnv +mkDeBruijnContext = extendCMEs emptyCME + +-- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g), +-- you'll find entries inserted under (t), even if (g) is non-reflexive. +newtype LooseTypeMap a + = LooseTypeMap (TypeMapG a) + +instance TrieMap LooseTypeMap where + type Key LooseTypeMap = Type + emptyTM = LooseTypeMap emptyTM + lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m + alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m) + foldTM f (LooseTypeMap m) = foldTM f m + mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m) + +{- +************************************************************************ +* * + Variables +* * +************************************************************************ +-} + +type BoundVar = Int -- Bound variables are deBruijn numbered +type BoundVarMap a = IntMap.IntMap a + +data CmEnv = CME { cme_next :: !BoundVar + , cme_env :: VarEnv BoundVar } + +emptyCME :: CmEnv +emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv } + +extendCME :: CmEnv -> Var -> CmEnv +extendCME (CME { cme_next = bv, cme_env = env }) v + = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv } + +extendCMEs :: CmEnv -> [Var] -> CmEnv +extendCMEs env vs = foldl' extendCME env vs + +lookupCME :: CmEnv -> Var -> Maybe BoundVar +lookupCME (CME { cme_env = env }) v = lookupVarEnv env v + +-- | @DeBruijn a@ represents @a@ modulo alpha-renaming. This is achieved +-- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn +-- numbering. This allows us to define an 'Eq' instance for @DeBruijn a@, even +-- if this was not (easily) possible for @a@. Note: we purposely don't +-- export the constructor. Make a helper function if you find yourself +-- needing it. +data DeBruijn a = D CmEnv a + +-- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no +-- bound binders (an empty 'CmEnv'). This is usually what you want if there +-- isn't already a 'CmEnv' in scope. +deBruijnize :: a -> DeBruijn a +deBruijnize = D emptyCME + +instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where + D _ [] == D _ [] = True + D env (x:xs) == D env' (x':xs') = D env x == D env' x' && + D env xs == D env' xs' + _ == _ = False + +--------- Variable binders ------------- + +-- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between +-- binding forms whose binders have different types. For example, +-- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should +-- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@: +-- we can disambiguate this by matching on the type (or kind, if this +-- a binder in a type) of the binder. +type BndrMap = TypeMapG + +-- Note [Binders] +-- ~~~~~~~~~~~~~~ +-- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all +-- of these data types have binding forms. + +lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a +lkBndr env v m = lkG (D env (varType v)) m + +xtBndr :: CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a +xtBndr env v f = xtG (D env (varType v)) f + +--------- Variable occurrence ------------- +data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable + , vm_fvar :: DVarEnv a } -- Free variable + +instance TrieMap VarMap where + type Key VarMap = Var + emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv } + lookupTM = lkVar emptyCME + alterTM = xtVar emptyCME + foldTM = fdVar + mapTM = mapVar + +mapVar :: (a->b) -> VarMap a -> VarMap b +mapVar f (VM { vm_bvar = bv, vm_fvar = fv }) + = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv } + +lkVar :: CmEnv -> Var -> VarMap a -> Maybe a +lkVar env v + | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv + | otherwise = vm_fvar >.> lkDFreeVar v + +xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a +xtVar env v f m + | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f } + | otherwise = m { vm_fvar = vm_fvar m |> xtDFreeVar v f } + +fdVar :: (a -> b -> b) -> VarMap a -> b -> b +fdVar k m = foldTM k (vm_bvar m) + . foldTM k (vm_fvar m) + +lkDFreeVar :: Var -> DVarEnv a -> Maybe a +lkDFreeVar var env = lookupDVarEnv env var + +xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a +xtDFreeVar v f m = alterDVarEnv f m v diff --git a/compiler/GHC/Core/Op/Tidy.hs b/compiler/GHC/Core/Op/Tidy.hs new file mode 100644 index 0000000000..8ddd3708c3 --- /dev/null +++ b/compiler/GHC/Core/Op/Tidy.hs @@ -0,0 +1,286 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +This module contains "tidying" code for *nested* expressions, bindings, rules. +The code for *top-level* bindings is in GHC.Iface.Tidy. +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +module GHC.Core.Op.Tidy ( + tidyExpr, tidyRules, tidyUnfolding + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core +import GHC.Core.Seq ( seqUnfolding ) +import Id +import IdInfo +import Demand ( zapUsageEnvSig ) +import Type( tidyType, tidyVarBndr ) +import Coercion( tidyCo ) +import Var +import VarEnv +import UniqFM +import Name hiding (tidyNameOcc) +import SrcLoc +import Maybes +import Data.List + +{- +************************************************************************ +* * +\subsection{Tidying expressions, rules} +* * +************************************************************************ +-} + +tidyBind :: TidyEnv + -> CoreBind + -> (TidyEnv, CoreBind) + +tidyBind env (NonRec bndr rhs) + = tidyLetBndr env env bndr =: \ (env', bndr') -> + (env', NonRec bndr' (tidyExpr env' rhs)) + +tidyBind env (Rec prs) + = let + (bndrs, rhss) = unzip prs + (env', bndrs') = mapAccumL (tidyLetBndr env') env bndrs + in + map (tidyExpr env') rhss =: \ rhss' -> + (env', Rec (zip bndrs' rhss')) + + +------------ Expressions -------------- +tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr +tidyExpr env (Var v) = Var (tidyVarOcc env v) +tidyExpr env (Type ty) = Type (tidyType env ty) +tidyExpr env (Coercion co) = Coercion (tidyCo env co) +tidyExpr _ (Lit lit) = Lit lit +tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) +tidyExpr env (Tick t e) = Tick (tidyTickish env t) (tidyExpr env e) +tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co) + +tidyExpr env (Let b e) + = tidyBind env b =: \ (env', b') -> + Let b' (tidyExpr env' e) + +tidyExpr env (Case e b ty alts) + = tidyBndr env b =: \ (env', b) -> + Case (tidyExpr env e) b (tidyType env ty) + (map (tidyAlt env') alts) + +tidyExpr env (Lam b e) + = tidyBndr env b =: \ (env', b) -> + Lam b (tidyExpr env' e) + +------------ Case alternatives -------------- +tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt +tidyAlt env (con, vs, rhs) + = tidyBndrs env vs =: \ (env', vs) -> + (con, vs, tidyExpr env' rhs) + +------------ Tickish -------------- +tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id +tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids) +tidyTickish _ other_tickish = other_tickish + +------------ Rules -------------- +tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule] +tidyRules _ [] = [] +tidyRules env (rule : rules) + = tidyRule env rule =: \ rule -> + tidyRules env rules =: \ rules -> + (rule : rules) + +tidyRule :: TidyEnv -> CoreRule -> CoreRule +tidyRule _ rule@(BuiltinRule {}) = rule +tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs, + ru_fn = fn, ru_rough = mb_ns }) + = tidyBndrs env bndrs =: \ (env', bndrs) -> + map (tidyExpr env') args =: \ args -> + rule { ru_bndrs = bndrs, ru_args = args, + ru_rhs = tidyExpr env' rhs, + ru_fn = tidyNameOcc env fn, + ru_rough = map (fmap (tidyNameOcc env')) mb_ns } + +{- +************************************************************************ +* * +\subsection{Tidying non-top-level binders} +* * +************************************************************************ +-} + +tidyNameOcc :: TidyEnv -> Name -> Name +-- In rules and instances, we have Names, and we must tidy them too +-- Fortunately, we can lookup in the VarEnv with a name +tidyNameOcc (_, var_env) n = case lookupUFM var_env n of + Nothing -> n + Just v -> idName v + +tidyVarOcc :: TidyEnv -> Var -> Var +tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v + +-- tidyBndr is used for lambda and case binders +tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) +tidyBndr env var + | isTyCoVar var = tidyVarBndr env var + | otherwise = tidyIdBndr env var + +tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +tidyBndrs env vars = mapAccumL tidyBndr env vars + +-- Non-top-level variables, not covars +tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) +tidyIdBndr env@(tidy_env, var_env) id + = -- Do this pattern match strictly, otherwise we end up holding on to + -- stuff in the OccName. + case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + -- Give the Id a fresh print-name, *and* rename its type + -- The SrcLoc isn't important now, + -- though we could extract it from the Id + -- + ty' = tidyType env (idType id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + id' = mkLocalIdWithInfo name' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + new_info = vanillaIdInfo `setOccInfo` occInfo old_info + `setUnfoldingInfo` new_unf + -- see Note [Preserve OneShotInfo] + `setOneShotInfo` oneShotInfo old_info + old_info = idInfo id + old_unf = unfoldingInfo old_info + new_unf = zapUnfolding old_unf -- See Note [Preserve evaluatedness] + in + ((tidy_env', var_env'), id') + } + +tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings + -> TidyEnv -- The one to extend + -> Id -> (TidyEnv, Id) +-- Used for local (non-top-level) let(rec)s +-- Just like tidyIdBndr above, but with more IdInfo +tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id + = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + ty' = tidyType env (idType id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + details = idDetails id + id' = mkLocalVar details name' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + -- We need to keep around any interesting strictness and + -- demand info because later on we may need to use it when + -- converting to A-normal form. + -- eg. + -- f (g x), where f is strict in its argument, will be converted + -- into case (g x) of z -> f z by CorePrep, but only if f still + -- has its strictness info. + -- + -- Similarly for the demand info - on a let binder, this tells + -- CorePrep to turn the let into a case. + -- But: Remove the usage demand here + -- (See Note [Zapping DmdEnv after Demand Analyzer] in WorkWrap) + -- + -- Similarly arity info for eta expansion in CorePrep + -- Don't attempt to recompute arity here; this is just tidying! + -- Trying to do so led to #17294 + -- + -- Set inline-prag info so that we preserve it across + -- separate compilation boundaries + old_info = idInfo id + new_info = vanillaIdInfo + `setOccInfo` occInfo old_info + `setArityInfo` arityInfo old_info + `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info) + `setDemandInfo` demandInfo old_info + `setInlinePragInfo` inlinePragInfo old_info + `setUnfoldingInfo` new_unf + + old_unf = unfoldingInfo old_info + new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf + | otherwise = zapUnfolding old_unf + -- See Note [Preserve evaluatedness] + + in + ((tidy_env', var_env'), id') } + +------------ Unfolding -------------- +tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding +tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _ + = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args } + where + (tidy_env', bndrs') = tidyBndrs tidy_env bndrs + +tidyUnfolding tidy_env + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + unf_from_rhs + | isStableSource src + = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo + -- This seqIt avoids a space leak: otherwise the uf_is_value, + -- uf_is_conlike, ... fields may retain a reference to the + -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them) + + | otherwise + = unf_from_rhs + where seqIt unf = seqUnfolding unf `seq` unf +tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon + +{- +Note [Tidy IdInfo] +~~~~~~~~~~~~~~~~~~ +All nested Ids now have the same IdInfo, namely vanillaIdInfo, which +should save some space; except that we preserve occurrence info for +two reasons: + + (a) To make printing tidy core nicer + + (b) Because we tidy RULES and InlineRules, which may then propagate + via --make into the compilation of the next module, and we want + the benefit of that occurrence analysis when we use the rule or + or inline the function. In particular, it's vital not to lose + loop-breaker info, else we get an infinite inlining loop + +Note that tidyLetBndr puts more IdInfo back. + +Note [Preserve evaluatedness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Bool + ....(case v of MkT y -> + let z# = case y of + True -> 1# + False -> 2# + in ...) + +The z# binding is ok because the RHS is ok-for-speculation, +but Lint will complain unless it can *see* that. So we +preserve the evaluated-ness on 'y' in tidyBndr. + +(Another alternative would be to tidy unboxed lets into cases, +but that seems more indirect and surprising.) + +Note [Preserve OneShotInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We keep the OneShotInfo because we want it to propagate into the interface. +Not all OneShotInfo is determined by a compiler analysis; some is added by a +call of GHC.Exts.oneShot, which is then discarded before the end of the +optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we +must preserve this info in inlinings. See Note [The oneShot function] in MkId. + +This applies to lambda binders only, hence it is stored in IfaceLamBndr. +-} + +(=:) :: a -> (a -> b) -> b +m =: k = m `seq` k m diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs new file mode 100644 index 0000000000..bd2b968ef4 --- /dev/null +++ b/compiler/GHC/Core/Ppr.hs @@ -0,0 +1,657 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +Printing of Core syntax +-} + +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.Core.Ppr ( + pprCoreExpr, pprParendExpr, + pprCoreBinding, pprCoreBindings, pprCoreAlt, + pprCoreBindingWithSize, pprCoreBindingsWithSize, + pprRules, pprOptCo + ) where + +import GhcPrelude + +import GHC.Core +import GHC.Core.Stats (exprStats) +import Literal( pprLiteral ) +import Name( pprInfixName, pprPrefixName ) +import Var +import Id +import IdInfo +import Demand +import Cpr +import DataCon +import TyCon +import TyCoPpr +import Coercion +import BasicTypes +import Maybes +import Util +import Outputable +import FastString +import SrcLoc ( pprUserRealSpan ) + +{- +************************************************************************ +* * +\subsection{Public interfaces for Core printing (excluding instances)} +* * +************************************************************************ + +@pprParendCoreExpr@ puts parens around non-atomic Core expressions. +-} + +pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc +pprCoreBinding :: OutputableBndr b => Bind b -> SDoc +pprCoreExpr :: OutputableBndr b => Expr b -> SDoc +pprParendExpr :: OutputableBndr b => Expr b -> SDoc + +pprCoreBindings = pprTopBinds noAnn +pprCoreBinding = pprTopBind noAnn + +pprCoreBindingsWithSize :: [CoreBind] -> SDoc +pprCoreBindingWithSize :: CoreBind -> SDoc + +pprCoreBindingsWithSize = pprTopBinds sizeAnn +pprCoreBindingWithSize = pprTopBind sizeAnn + +instance OutputableBndr b => Outputable (Bind b) where + ppr bind = ppr_bind noAnn bind + +instance OutputableBndr b => Outputable (Expr b) where + ppr expr = pprCoreExpr expr + +{- +************************************************************************ +* * +\subsection{The guts} +* * +************************************************************************ +-} + +-- | A function to produce an annotation for a given right-hand-side +type Annotation b = Expr b -> SDoc + +-- | Annotate with the size of the right-hand-side +sizeAnn :: CoreExpr -> SDoc +sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e) + +-- | No annotation +noAnn :: Expr b -> SDoc +noAnn _ = empty + +pprTopBinds :: OutputableBndr a + => Annotation a -- ^ generate an annotation to place before the + -- binding + -> [Bind a] -- ^ bindings to show + -> SDoc -- ^ the pretty result +pprTopBinds ann binds = vcat (map (pprTopBind ann) binds) + +pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc +pprTopBind ann (NonRec binder expr) + = ppr_binding ann (binder,expr) $$ blankLine + +pprTopBind _ (Rec []) + = text "Rec { }" +pprTopBind ann (Rec (b:bs)) + = vcat [text "Rec {", + ppr_binding ann b, + vcat [blankLine $$ ppr_binding ann b | b <- bs], + text "end Rec }", + blankLine] + +ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc + +ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr) +ppr_bind ann (Rec binds) = vcat (map pp binds) + where + pp bind = ppr_binding ann bind <> semi + +ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc +ppr_binding ann (val_bdr, expr) + = vcat [ ann expr + , ppUnlessOption sdocSuppressTypeSignatures + (pprBndr LetBind val_bdr) + , pp_bind + ] + where + pp_bind = case bndrIsJoin_maybe val_bdr of + Nothing -> pp_normal_bind + Just ar -> pp_join_bind ar + + pp_normal_bind = hang (ppr val_bdr) 2 (equals <+> pprCoreExpr expr) + + -- For a join point of join arity n, we want to print j = \x1 ... xn -> e + -- as "j x1 ... xn = e" to differentiate when a join point returns a + -- lambda (the first rendering looks like a nullary join point returning + -- an n-argument function). + pp_join_bind join_arity + | bndrs `lengthAtLeast` join_arity + = hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs)) + 2 (equals <+> pprCoreExpr rhs) + | otherwise -- Yikes! A join-binding with too few lambda + -- Lint will complain, but we don't want to crash + -- the pretty-printer else we can't see what's wrong + -- So refer to printing j = e + = pp_normal_bind + where + (bndrs, body) = collectBinders expr + lhs_bndrs = take join_arity bndrs + rhs = mkLams (drop join_arity bndrs) body + +pprParendExpr expr = ppr_expr parens expr +pprCoreExpr expr = ppr_expr noParens expr + +noParens :: SDoc -> SDoc +noParens pp = pp + +pprOptCo :: Coercion -> SDoc +-- Print a coercion optionally; i.e. honouring -dsuppress-coercions +pprOptCo co = sdocOption sdocSuppressCoercions $ \case + True -> angleBrackets (text "Co:" <> int (coercionSize co)) + False -> parens $ sep [ppr co, dcolon <+> ppr (coercionType co)] + +ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) + +ppr_expr add_par (Var name) + | isJoinId name = add_par ((text "jump") <+> ppr name) + | otherwise = ppr name +ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird +ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co) +ppr_expr add_par (Lit lit) = pprLiteral add_par lit + +ppr_expr add_par (Cast expr co) + = add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co] + +ppr_expr add_par expr@(Lam _ _) + = let + (bndrs, body) = collectBinders expr + in + add_par $ + hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (pprCoreExpr body) + +ppr_expr add_par expr@(App {}) + = sdocOption sdocSuppressTypeApplications $ \supp_ty_app -> + case collectArgs expr of { (fun, args) -> + let + pp_args = sep (map pprArg args) + val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples + pp_tup_args = pprWithCommas pprCoreExpr val_args + args' + | supp_ty_app = val_args + | otherwise = args + parens + | null args' = id + | otherwise = add_par + in + case fun of + Var f -> case isDataConWorkId_maybe f of + -- Notice that we print the *worker* + -- for tuples in paren'd format. + Just dc | saturated + , Just sort <- tyConTuple_maybe tc + -> tupleParens sort pp_tup_args + where + tc = dataConTyCon dc + saturated = val_args `lengthIs` idArity f + + _ -> parens (hang fun_doc 2 pp_args) + where + fun_doc | isJoinId f = text "jump" <+> ppr f + | otherwise = ppr f + + _ -> parens (hang (pprParendExpr fun) 2 pp_args) + } + +ppr_expr add_par (Case expr var ty [(con,args,rhs)]) + = sdocOption sdocPrintCaseAsLet $ \case + True -> add_par $ -- See Note [Print case as let] + sep [ sep [ text "let! {" + <+> ppr_case_pat con args + <+> text "~" + <+> ppr_bndr var + , text "<-" <+> ppr_expr id expr + <+> text "} in" ] + , pprCoreExpr rhs + ] + False -> add_par $ + sep [sep [sep [ text "case" <+> pprCoreExpr expr + , whenPprDebug (text "return" <+> ppr ty) + , text "of" <+> ppr_bndr var + ] + , char '{' <+> ppr_case_pat con args <+> arrow + ] + , pprCoreExpr rhs + , char '}' + ] + where + ppr_bndr = pprBndr CaseBind + +ppr_expr add_par (Case expr var ty alts) + = add_par $ + sep [sep [text "case" + <+> pprCoreExpr expr + <+> whenPprDebug (text "return" <+> ppr ty), + text "of" <+> ppr_bndr var <+> char '{'], + nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), + char '}' + ] + where + ppr_bndr = pprBndr CaseBind + + +-- special cases: let ... in let ... +-- ("disgusting" SLPJ) + +{- +ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) + = add_par $ + vcat [ + hsep [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], + nest 2 (pprCoreExpr rhs), + text "} in", + pprCoreExpr body ] + +ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) + = add_par + (hang (text "let {") + 2 (hsep [ppr_binding (val_bdr,rhs), + text "} in"]) + $$ + pprCoreExpr expr) +-} + + +-- General case (recursive case, too) +ppr_expr add_par (Let bind expr) + = add_par $ + sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"), + pprCoreExpr expr] + where + keyword (NonRec b _) + | isJust (bndrIsJoin_maybe b) = text "join" + | otherwise = text "let" + keyword (Rec pairs) + | ((b,_):_) <- pairs + , isJust (bndrIsJoin_maybe b) = text "joinrec" + | otherwise = text "letrec" + +ppr_expr add_par (Tick tickish expr) + = sdocOption sdocSuppressTicks $ \case + True -> ppr_expr add_par expr + False -> add_par (sep [ppr tickish, pprCoreExpr expr]) + +pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc +pprCoreAlt (con, args, rhs) + = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) + +ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc +ppr_case_pat (DataAlt dc) args + | Just sort <- tyConTuple_maybe tc + = tupleParens sort (pprWithCommas ppr_bndr args) + where + ppr_bndr = pprBndr CasePatBind + tc = dataConTyCon dc + +ppr_case_pat con args + = ppr con <+> (fsep (map ppr_bndr args)) + where + ppr_bndr = pprBndr CasePatBind + + +-- | Pretty print the argument in a function application. +pprArg :: OutputableBndr a => Expr a -> SDoc +pprArg (Type ty) + = ppUnlessOption sdocSuppressTypeApplications + (text "@" <> pprParendType ty) +pprArg (Coercion co) = text "@~" <> pprOptCo co +pprArg expr = pprParendExpr expr + +{- +Note [Print case as let] +~~~~~~~~~~~~~~~~~~~~~~~~ +Single-branch case expressions are very common: + case x of y { I# x' -> + case p of q { I# p' -> ... } } +These are, in effect, just strict let's, with pattern matching. +With -dppr-case-as-let we print them as such: + let! { I# x' ~ y <- x } in + let! { I# p' ~ q <- p } in ... + + +Other printing bits-and-bobs used with the general @pprCoreBinding@ +and @pprCoreExpr@ functions. + + +Note [Binding-site specific printing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust +the information printed. + +Let-bound binders are printed with their full type and idInfo. + +Case-bound variables (both the case binder and pattern variables) are printed +without a type and without their unfolding. + +Furthermore, a dead case-binder is completely ignored, while otherwise, dead +binders are printed as "_". +-} + +-- These instances are sadly orphans + +instance OutputableBndr Var where + pprBndr = pprCoreBinder + pprInfixOcc = pprInfixName . varName + pprPrefixOcc = pprPrefixName . varName + bndrIsJoin_maybe = isJoinId_maybe + +instance Outputable b => OutputableBndr (TaggedBndr b) where + pprBndr _ b = ppr b -- Simple + pprInfixOcc b = ppr b + pprPrefixOcc b = ppr b + bndrIsJoin_maybe (TB b _) = isJoinId_maybe b + +pprCoreBinder :: BindingSite -> Var -> SDoc +pprCoreBinder LetBind binder + | isTyVar binder = pprKindedTyVarBndr binder + | otherwise = pprTypedLetBinder binder $$ + ppIdInfo binder (idInfo binder) + +-- Lambda bound type variables are preceded by "@" +pprCoreBinder bind_site bndr + = getPprStyle $ \ sty -> + pprTypedLamBinder bind_site (debugStyle sty) bndr + +pprUntypedBinder :: Var -> SDoc +pprUntypedBinder binder + | isTyVar binder = text "@" <> ppr binder -- NB: don't print kind + | otherwise = pprIdBndr binder + +pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc +-- For lambda and case binders, show the unfolding info (usually none) +pprTypedLamBinder bind_site debug_on var + = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs -> + case () of + _ + | not debug_on -- Show case-bound wild binders only if debug is on + , CaseBind <- bind_site + , isDeadBinder var -> empty + + | not debug_on -- Even dead binders can be one-shot + , isDeadBinder var -> char '_' <+> ppWhen (isId var) + (pprIdBndrInfo (idInfo var)) + + | not debug_on -- No parens, no kind info + , CaseBind <- bind_site -> pprUntypedBinder var + + | not debug_on + , CasePatBind <- bind_site -> pprUntypedBinder var + + | suppress_sigs -> pprUntypedBinder var + + | isTyVar var -> parens (pprKindedTyVarBndr var) + + | otherwise -> parens (hang (pprIdBndr var) + 2 (vcat [ dcolon <+> pprType (idType var) + , pp_unf])) + where + unf_info = unfoldingInfo (idInfo var) + pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info + | otherwise = empty + +pprTypedLetBinder :: Var -> SDoc +-- Print binder with a type or kind signature (not paren'd) +pprTypedLetBinder binder + = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs -> + case () of + _ + | isTyVar binder -> pprKindedTyVarBndr binder + | suppress_sigs -> pprIdBndr binder + | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) + +pprKindedTyVarBndr :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +pprKindedTyVarBndr tyvar + = text "@" <> pprTyVar tyvar + +-- pprIdBndr does *not* print the type +-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness +pprIdBndr :: Id -> SDoc +pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) + +pprIdBndrInfo :: IdInfo -> SDoc +pprIdBndrInfo info + = ppUnlessOption sdocSuppressIdInfo + (info `seq` doc) -- The seq is useful for poking on black holes + where + prag_info = inlinePragInfo info + occ_info = occInfo info + dmd_info = demandInfo info + lbv_info = oneShotInfo info + + has_prag = not (isDefaultInlinePragma prag_info) + has_occ = not (isManyOccs occ_info) + has_dmd = not $ isTopDmd dmd_info + has_lbv = not (hasNoOneShotInfo lbv_info) + + doc = showAttributes + [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info) + , (has_occ, text "Occ=" <> ppr occ_info) + , (has_dmd, text "Dmd=" <> ppr dmd_info) + , (has_lbv , text "OS=" <> ppr lbv_info) + ] + +instance Outputable IdInfo where + ppr info = showAttributes + [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info) + , (has_occ, text "Occ=" <> ppr occ_info) + , (has_dmd, text "Dmd=" <> ppr dmd_info) + , (has_lbv , text "OS=" <> ppr lbv_info) + , (has_arity, text "Arity=" <> int arity) + , (has_called_arity, text "CallArity=" <> int called_arity) + , (has_caf_info, text "Caf=" <> ppr caf_info) + , (has_str_info, text "Str=" <> pprStrictness str_info) + , (has_unf, text "Unf=" <> ppr unf_info) + , (has_rules, text "RULES:" <+> vcat (map pprRule rules)) + ] + where + prag_info = inlinePragInfo info + has_prag = not (isDefaultInlinePragma prag_info) + + occ_info = occInfo info + has_occ = not (isManyOccs occ_info) + + dmd_info = demandInfo info + has_dmd = not $ isTopDmd dmd_info + + lbv_info = oneShotInfo info + has_lbv = not (hasNoOneShotInfo lbv_info) + + arity = arityInfo info + has_arity = arity /= 0 + + called_arity = callArityInfo info + has_called_arity = called_arity /= 0 + + caf_info = cafInfo info + has_caf_info = not (mayHaveCafRefs caf_info) + + str_info = strictnessInfo info + has_str_info = not (isTopSig str_info) + + unf_info = unfoldingInfo info + has_unf = hasSomeUnfolding unf_info + + rules = ruleInfoRules (ruleInfo info) + has_rules = not (null rules) + +{- +----------------------------------------------------- +-- IdDetails and IdInfo +----------------------------------------------------- +-} + +ppIdInfo :: Id -> IdInfo -> SDoc +ppIdInfo id info + = ppUnlessOption sdocSuppressIdInfo $ + showAttributes + [ (True, pp_scope <> ppr (idDetails id)) + , (has_arity, text "Arity=" <> int arity) + , (has_called_arity, text "CallArity=" <> int called_arity) + , (has_caf_info, text "Caf=" <> ppr caf_info) + , (has_str_info, text "Str=" <> pprStrictness str_info) + , (has_cpr_info, text "Cpr=" <> ppr cpr_info) + , (has_unf, text "Unf=" <> ppr unf_info) + , (not (null rules), text "RULES:" <+> vcat (map pprRule rules)) + ] -- Inline pragma, occ, demand, one-shot info + -- printed out with all binders (when debug is on); + -- see GHC.Core.Ppr.pprIdBndr + where + pp_scope | isGlobalId id = text "GblId" + | isExportedId id = text "LclIdX" + | otherwise = text "LclId" + + arity = arityInfo info + has_arity = arity /= 0 + + called_arity = callArityInfo info + has_called_arity = called_arity /= 0 + + caf_info = cafInfo info + has_caf_info = not (mayHaveCafRefs caf_info) + + str_info = strictnessInfo info + has_str_info = not (isTopSig str_info) + + cpr_info = cprInfo info + has_cpr_info = cpr_info /= topCprSig + + unf_info = unfoldingInfo info + has_unf = hasSomeUnfolding unf_info + + rules = ruleInfoRules (ruleInfo info) + +showAttributes :: [(Bool,SDoc)] -> SDoc +showAttributes stuff + | null docs = empty + | otherwise = brackets (sep (punctuate comma docs)) + where + docs = [d | (True,d) <- stuff] + +{- +----------------------------------------------------- +-- Unfolding and UnfoldingGuidance +----------------------------------------------------- +-} + +instance Outputable UnfoldingGuidance where + ppr UnfNever = text "NEVER" + ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }) + = text "ALWAYS_IF" <> + parens (text "arity=" <> int arity <> comma <> + text "unsat_ok=" <> ppr unsat_ok <> comma <> + text "boring_ok=" <> ppr boring_ok) + ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) + = hsep [ text "IF_ARGS", + brackets (hsep (map int cs)), + int size, + int discount ] + +instance Outputable UnfoldingSource where + ppr InlineCompulsory = text "Compulsory" + ppr InlineStable = text "InlineStable" + ppr InlineRhs = text "<vanilla>" + +instance Outputable Unfolding where + ppr NoUnfolding = text "No unfolding" + ppr BootUnfolding = text "No unfolding (from boot)" + ppr (OtherCon cs) = text "OtherCon" <+> ppr cs + ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = hang (text "DFun:" <+> ptext (sLit "\\") + <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (ppr con <+> sep (map ppr args)) + ppr (CoreUnfolding { uf_src = src + , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf + , uf_is_conlike=conlike, uf_is_work_free=wf + , uf_expandable=exp, uf_guidance=g }) + = text "Unf" <> braces (pp_info $$ pp_rhs) + where + pp_info = fsep $ punctuate comma + [ text "Src=" <> ppr src + , text "TopLvl=" <> ppr top + , text "Value=" <> ppr hnf + , text "ConLike=" <> ppr conlike + , text "WorkFree=" <> ppr wf + , text "Expandable=" <> ppr exp + , text "Guidance=" <> ppr g ] + pp_tmpl = ppUnlessOption sdocSuppressUnfoldings + (text "Tmpl=" <+> ppr rhs) + pp_rhs | isStableSource src = pp_tmpl + | otherwise = empty + -- Don't print the RHS or we get a quadratic + -- blowup in the size of the printout! + +{- +----------------------------------------------------- +-- Rules +----------------------------------------------------- +-} + +instance Outputable CoreRule where + ppr = pprRule + +pprRules :: [CoreRule] -> SDoc +pprRules rules = vcat (map pprRule rules) + +pprRule :: CoreRule -> SDoc +pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) + = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name) + +pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, + ru_bndrs = tpl_vars, ru_args = tpl_args, + ru_rhs = rhs }) + = hang (doubleQuotes (ftext name) <+> ppr act) + 4 (sep [text "forall" <+> + sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, + nest 2 (ppr fn <+> sep (map pprArg tpl_args)), + nest 2 (text "=" <+> pprCoreExpr rhs) + ]) + +{- +----------------------------------------------------- +-- Tickish +----------------------------------------------------- +-} + +instance Outputable id => Outputable (Tickish id) where + ppr (HpcTick modl ix) = + hcat [text "hpc<", + ppr modl, comma, + ppr ix, + text ">"] + ppr (Breakpoint ix vars) = + hcat [text "break<", + ppr ix, + text ">", + parens (hcat (punctuate comma (map ppr vars)))] + ppr (ProfNote { profNoteCC = cc, + profNoteCount = tick, + profNoteScope = scope }) = + case (tick,scope) of + (True,True) -> hcat [text "scctick<", ppr cc, char '>'] + (True,False) -> hcat [text "tick<", ppr cc, char '>'] + _ -> hcat [text "scc<", ppr cc, char '>'] + ppr (SourceNote span _) = + hcat [ text "src<", pprUserRealSpan True span, char '>'] diff --git a/compiler/GHC/Core/Ppr/TyThing.hs b/compiler/GHC/Core/Ppr/TyThing.hs new file mode 100644 index 0000000000..b11cd6edb2 --- /dev/null +++ b/compiler/GHC/Core/Ppr/TyThing.hs @@ -0,0 +1,205 @@ +----------------------------------------------------------------------------- +-- +-- Pretty-printing TyThings +-- +-- (c) The GHC Team 2005 +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +module GHC.Core.Ppr.TyThing ( + pprTyThing, + pprTyThingInContext, + pprTyThingLoc, + pprTyThingInContextLoc, + pprTyThingHdr, + pprTypeForUser, + pprFamInst + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Type ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) +import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) + , showToHeader, pprIfaceDecl ) +import CoAxiom ( coAxiomTyCon ) +import GHC.Driver.Types( tyThingParent_maybe ) +import GHC.Iface.Utils ( tyThingToIfaceDecl ) +import FamInstEnv( FamInst(..), FamFlavor(..) ) +import TyCoPpr ( pprUserForAll, pprTypeApp, pprSigmaType ) +import Name +import VarEnv( emptyTidyEnv ) +import Outputable + +-- ----------------------------------------------------------------------------- +-- Pretty-printing entities that we get from the GHC API + +{- Note [Pretty printing via Iface syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our general plan for pretty-printing + - Types + - TyCons + - Classes + - Pattern synonyms + ...etc... + +is to convert them to Iface syntax, and pretty-print that. For example + - pprType converts a Type to an IfaceType, and pretty prints that. + - pprTyThing converts the TyThing to an IfaceDecl, + and pretty prints that. + +So Iface syntax plays a dual role: + - it's the internal version of an interface files + - it's used for pretty-printing + +Why do this? + +* A significant reason is that we need to be able + to pretty-print Iface syntax (to display Foo.hi), and it was a + pain to duplicate masses of pretty-printing goop, esp for + Type and IfaceType. + +* When pretty-printing (a type, say), we want to tidy (with + tidyType) to avoids having (forall a a. blah) where the two + a's have different uniques. + + Alas, for type constructors, TyCon, tidying does not work well, + because a TyCon includes DataCons which include Types, which mention + TyCons. And tidying can't tidy a mutually recursive data structure + graph, only trees. + +* Interface files contains fast-strings, not uniques, so the very same + tidying must take place when we convert to IfaceDecl. E.g. + GHC.Iface.Utils.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon, + Class etc) to an IfaceDecl. + + Bottom line: IfaceDecls are already 'tidy', so it's straightforward + to print them. + +* An alternative I once explored was to ensure that TyCons get type + variables with distinct print-names. That's ok for type variables + but less easy for kind variables. Processing data type declarations + is already so complicated that I don't think it's sensible to add + the extra requirement that it generates only "pretty" types and + kinds. + +Consequences: + +- Iface syntax (and IfaceType) must contain enough information to + print nicely. Hence, for example, the IfaceAppArgs type, which + allows us to suppress invisible kind arguments in types + (see Note [Suppressing invisible arguments] in GHC.Iface.Type) + +- In a few places we have info that is used only for pretty-printing, + and is totally ignored when turning Iface syntax back into Core + (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon + stores a [IfaceAxBranch] that is used only for pretty-printing. + +- See Note [Free tyvars in IfaceType] in GHC.Iface.Type + +See #7730, #8776 for details -} + +-------------------- +-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location. +pprFamInst :: FamInst -> SDoc +-- * For data instances we go via pprTyThing of the representational TyCon, +-- because there is already much cleverness associated with printing +-- data type declarations that I don't want to duplicate +-- * For type instances we print directly here; there is no TyCon +-- to give to pprTyThing +-- +-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes + +pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc }) + = pprTyThingInContextLoc (ATyCon rep_tc) + +pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom + , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs }) + = showWithLoc (pprDefinedAt (getName axiom)) $ + hang (text "type instance" + <+> pprUserForAll (mkTyVarBinders Specified tvs) + -- See Note [Printing foralls in type family instances] + -- in GHC.Iface.Type + <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) + 2 (equals <+> ppr rhs) + +---------------------------- +-- | Pretty-prints a 'TyThing' with its defining location. +pprTyThingLoc :: TyThing -> SDoc +pprTyThingLoc tyThing + = showWithLoc (pprDefinedAt (getName tyThing)) + (pprTyThing showToHeader tyThing) + +-- | Pretty-prints the 'TyThing' header. For functions and data constructors +-- the function is equivalent to 'pprTyThing' but for type constructors +-- and classes it prints only the header part of the declaration. +pprTyThingHdr :: TyThing -> SDoc +pprTyThingHdr = pprTyThing showToHeader + +-- | Pretty-prints a 'TyThing' in context: that is, if the entity +-- is a data constructor, record selector, or class method, then +-- the entity's parent declaration is pretty-printed with irrelevant +-- parts omitted. +pprTyThingInContext :: ShowSub -> TyThing -> SDoc +pprTyThingInContext show_sub thing + = go [] thing + where + go ss thing + = case tyThingParent_maybe thing of + Just parent -> + go (getOccName thing : ss) parent + Nothing -> + pprTyThing + (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) }) + thing + +-- | Like 'pprTyThingInContext', but adds the defining location. +pprTyThingInContextLoc :: TyThing -> SDoc +pprTyThingInContextLoc tyThing + = showWithLoc (pprDefinedAt (getName tyThing)) + (pprTyThingInContext showToHeader tyThing) + +-- | Pretty-prints a 'TyThing'. +pprTyThing :: ShowSub -> TyThing -> SDoc +-- We pretty-print 'TyThing' via 'IfaceDecl' +-- See Note [Pretty-printing TyThings] +pprTyThing ss ty_thing + = pprIfaceDecl ss' (tyThingToIfaceDecl ty_thing) + where + ss' = case ss_how_much ss of + ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' } + ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' } + _ -> ss + + ppr' = AltPpr $ ppr_bndr $ getName ty_thing + + ppr_bndr :: Name -> Maybe (OccName -> SDoc) + ppr_bndr name + | isBuiltInSyntax name + = Nothing + | otherwise + = case nameModule_maybe name of + Just mod -> Just $ \occ -> getPprStyle $ \sty -> + pprModulePrefix sty mod occ <> ppr occ + Nothing -> WARN( True, ppr name ) Nothing + -- Nothing is unexpected here; TyThings have External names + +pprTypeForUser :: Type -> SDoc +-- The type is tidied +pprTypeForUser ty + = pprSigmaType tidy_ty + where + (_, tidy_ty) = tidyOpenType emptyTidyEnv ty + -- Often the types/kinds we print in ghci are fully generalised + -- and have no free variables, but it turns out that we sometimes + -- print un-generalised kinds (eg when doing :k T), so it's + -- better to use tidyOpenType here + +showWithLoc :: SDoc -> SDoc -> SDoc +showWithLoc loc doc + = hang doc 2 (char '\t' <> comment <+> loc) + -- The tab tries to make them line up a bit + where + comment = text "--" diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs new file mode 100644 index 0000000000..9d2a209993 --- /dev/null +++ b/compiler/GHC/Core/Rules.hs @@ -0,0 +1,1254 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[CoreRules]{Transformation rules} +-} + +{-# LANGUAGE CPP #-} + +-- | Functions for collecting together and applying rewrite rules to a module. +-- The 'CoreRule' datatype itself is declared elsewhere. +module GHC.Core.Rules ( + -- ** Constructing + emptyRuleBase, mkRuleBase, extendRuleBaseList, + unionRuleBase, pprRuleBase, + + -- ** Checking rule applications + ruleCheckProgram, + + -- ** Manipulating 'RuleInfo' rules + mkRuleInfo, extendRuleInfo, addRuleInfo, + addIdSpecialisations, + + -- * Misc. CoreRule helpers + rulesOfBinds, getRules, pprRulesForUser, + + lookupRule, mkRule, roughTopNames + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core -- All of it +import Module ( Module, ModuleSet, elemModuleSet ) +import GHC.Core.Subst +import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) +import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars + , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) +import GHC.Core.Utils ( exprType, eqExpr, mkTick, mkTicks + , stripTicksTopT, stripTicksTopE + , isJoinBind ) +import GHC.Core.Ppr ( pprRules ) +import Type ( Type, TCvSubst, extendTvSubst, extendCvSubst + , mkEmptyTCvSubst, substTy ) +import TcType ( tcSplitTyConApp_maybe ) +import TysWiredIn ( anyTypeOfKind ) +import Coercion +import GHC.Core.Op.Tidy ( tidyRules ) +import Id +import IdInfo ( RuleInfo( RuleInfo ) ) +import Var +import VarEnv +import VarSet +import Name ( Name, NamedThing(..), nameIsLocalOrFrom ) +import NameSet +import NameEnv +import UniqFM +import Unify ( ruleMatchTyKiX ) +import BasicTypes +import GHC.Driver.Session ( DynFlags ) +import Outputable +import FastString +import Maybes +import Bag +import Util +import Data.List +import Data.Ord +import Control.Monad ( guard ) + +{- +Note [Overall plumbing for rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* After the desugarer: + - The ModGuts initially contains mg_rules :: [CoreRule] of + locally-declared rules for imported Ids. + - Locally-declared rules for locally-declared Ids are attached to + the IdInfo for that Id. See Note [Attach rules to local ids] in + GHC.HsToCore.Binds + +* GHC.Iface.Tidy strips off all the rules from local Ids and adds them to + mg_rules, so that the ModGuts has *all* the locally-declared rules. + +* The HomePackageTable contains a ModDetails for each home package + module. Each contains md_rules :: [CoreRule] of rules declared in + that module. The HomePackageTable grows as ghc --make does its + up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules + are treated by the "external" route, discussed next, regardless of + which package they come from. + +* The ExternalPackageState has a single eps_rule_base :: RuleBase for + Ids in other packages. This RuleBase simply grow monotonically, as + ghc --make compiles one module after another. + + During simplification, interface files may get demand-loaded, + as the simplifier explores the unfoldings for Ids it has in + its hand. (Via an unsafePerformIO; the EPS is really a cache.) + That in turn may make the EPS rule-base grow. In contrast, the + HPT never grows in this way. + +* The result of all this is that during Core-to-Core optimisation + there are four sources of rules: + + (a) Rules in the IdInfo of the Id they are a rule for. These are + easy: fast to look up, and if you apply a substitution then + it'll be applied to the IdInfo as a matter of course. + + (b) Rules declared in this module for imported Ids, kept in the + ModGuts. If you do a substitution, you'd better apply the + substitution to these. There are seldom many of these. + + (c) Rules declared in the HomePackageTable. These never change. + + (d) Rules in the ExternalPackageTable. These can grow in response + to lazy demand-loading of interfaces. + +* At the moment (c) is carried in a reader-monad way by the CoreMonad. + The HomePackageTable doesn't have a single RuleBase because technically + we should only be able to "see" rules "below" this module; so we + generate a RuleBase for (c) by combing rules from all the modules + "below" us. That's why we can't just select the home-package RuleBase + from HscEnv. + + [NB: we are inconsistent here. We should do the same for external + packages, but we don't. Same for type-class instances.] + +* So in the outer simplifier loop, we combine (b-d) into a single + RuleBase, reading + (b) from the ModGuts, + (c) from the CoreMonad, and + (d) from its mutable variable + [Of course this means that we won't see new EPS rules that come in + during a single simplifier iteration, but that probably does not + matter.] + + +************************************************************************ +* * +\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} +* * +************************************************************************ + +A @CoreRule@ holds details of one rule for an @Id@, which +includes its specialisations. + +For example, if a rule for @f@ contains the mapping: +\begin{verbatim} + forall a b d. [Type (List a), Type b, Var d] ===> f' a b +\end{verbatim} +then when we find an application of f to matching types, we simply replace +it by the matching RHS: +\begin{verbatim} + f (List Int) Bool dict ===> f' Int Bool +\end{verbatim} +All the stuff about how many dictionaries to discard, and what types +to apply the specialised function to, are handled by the fact that the +Rule contains a template for the result of the specialisation. + +There is one more exciting case, which is dealt with in exactly the same +way. If the specialised value is unboxed then it is lifted at its +definition site and unlifted at its uses. For example: + + pi :: forall a. Num a => a + +might have a specialisation + + [Int#] ===> (case pi' of Lift pi# -> pi#) + +where pi' :: Lift Int# is the specialised version of pi. +-} + +mkRule :: Module -> Bool -> Bool -> RuleName -> Activation + -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being +-- compiled. See also 'GHC.Core.CoreRule' +mkRule this_mod is_auto is_local name act fn bndrs args rhs + = Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs, ru_args = args, + ru_rhs = rhs, + ru_rough = roughTopNames args, + ru_origin = this_mod, + ru_orphan = orph, + ru_auto = is_auto, ru_local = is_local } + where + -- Compute orphanhood. See Note [Orphans] in InstEnv + -- A rule is an orphan only if none of the variables + -- mentioned on its left-hand side are locally defined + lhs_names = extendNameSet (exprsOrphNames args) fn + + -- Since rules get eventually attached to one of the free names + -- from the definition when compiling the ABI hash, we should make + -- it deterministic. This chooses the one with minimal OccName + -- as opposed to uniq value. + local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names + orph = chooseOrphanAnchor local_lhs_names + +-------------- +roughTopNames :: [CoreExpr] -> [Maybe Name] +-- ^ Find the \"top\" free names of several expressions. +-- Such names are either: +-- +-- 1. The function finally being applied to in an application chain +-- (if that name is a GlobalId: see "Var#globalvslocal"), or +-- +-- 2. The 'TyCon' if the expression is a 'Type' +-- +-- This is used for the fast-match-check for rules; +-- if the top names don't match, the rest can't +roughTopNames args = map roughTopName args + +roughTopName :: CoreExpr -> Maybe Name +roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of + Just (tc,_) -> Just (getName tc) + Nothing -> Nothing +roughTopName (Coercion _) = Nothing +roughTopName (App f _) = roughTopName f +roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] + , isDataConWorkId f || idArity f > 0 + = Just (idName f) +roughTopName (Tick t e) | tickishFloatable t + = roughTopName e +roughTopName _ = Nothing + +ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ +-- definitely can't match @tpl@ by instantiating @tpl@. +-- It's only a one-way match; unlike instance matching we +-- don't consider unification. +-- +-- Notice that [_$_] +-- @ruleCantMatch [Nothing] [Just n2] = False@ +-- Reason: a template variable can be instantiated by a constant +-- Also: +-- @ruleCantMatch [Just n1] [Nothing] = False@ +-- Reason: a local variable @v@ in the actuals might [_$_] + +ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as +ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as +ruleCantMatch _ _ = False + +{- +Note [Care with roughTopName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + module M where { x = a:b } + module N where { ...f x... + RULE f (p:q) = ... } +You'd expect the rule to match, because the matcher can +look through the unfolding of 'x'. So we must avoid roughTopName +returning 'M.x' for the call (f x), or else it'll say "can't match" +and we won't even try!! + +However, suppose we have + RULE g (M.h x) = ... + foo = ...(g (M.k v)).... +where k is a *function* exported by M. We never really match +functions (lambdas) except by name, so in this case it seems like +a good idea to treat 'M.k' as a roughTopName of the call. +-} + +pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc +-- (a) tidy the rules +-- (b) sort them into order based on the rule name +-- (c) suppress uniques (unless -dppr-debug is on) +-- This combination makes the output stable so we can use in testing +-- It's here rather than in GHC.Core.Ppr because it calls tidyRules +pprRulesForUser dflags rules + = withPprStyle (defaultUserStyle dflags) $ + pprRules $ + sortBy (comparing ruleName) $ + tidyRules emptyTidyEnv rules + +{- +************************************************************************ +* * + RuleInfo: the rules in an IdInfo +* * +************************************************************************ +-} + +-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable +-- for putting into an 'IdInfo' +mkRuleInfo :: [CoreRule] -> RuleInfo +mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) + +extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo +extendRuleInfo (RuleInfo rs1 fvs1) rs2 + = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1) + +addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo +addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2) + = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2) + +addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id rules + | null rules + = id + | otherwise + = setIdSpecialisation id $ + extendRuleInfo (idSpecialisation id) rules + +-- | Gather all the rules for locally bound identifiers from the supplied bindings +rulesOfBinds :: [CoreBind] -> [CoreRule] +rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds + +getRules :: RuleEnv -> Id -> [CoreRule] +-- See Note [Where rules are found] +getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn + = idCoreRules fn ++ filter (ruleIsVisible orphs) imp_rules + where + imp_rules = lookupNameEnv rule_base (idName fn) `orElse` [] + +ruleIsVisible :: ModuleSet -> CoreRule -> Bool +ruleIsVisible _ BuiltinRule{} = True +ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin } + = notOrphan orph || origin `elemModuleSet` vis_orphs + +{- Note [Where rules are found] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rules for an Id come from two places: + (a) the ones it is born with, stored inside the Id itself (idCoreRules fn), + (b) rules added in other modules, stored in the global RuleBase (imp_rules) + +It's tempting to think that + - LocalIds have only (a) + - non-LocalIds have only (b) + +but that isn't quite right: + + - PrimOps and ClassOps are born with a bunch of rules inside the Id, + even when they are imported + + - The rules in PrelRules.builtinRules should be active even + in the module defining the Id (when it's a LocalId), but + the rules are kept in the global RuleBase + + +************************************************************************ +* * + RuleBase +* * +************************************************************************ +-} + +-- RuleBase itself is defined in GHC.Core, along with CoreRule + +emptyRuleBase :: RuleBase +emptyRuleBase = emptyNameEnv + +mkRuleBase :: [CoreRule] -> RuleBase +mkRuleBase rules = extendRuleBaseList emptyRuleBase rules + +extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl' extendRuleBase rule_base new_guys + +unionRuleBase :: RuleBase -> RuleBase -> RuleBase +unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2 + +extendRuleBase :: RuleBase -> CoreRule -> RuleBase +extendRuleBase rule_base rule + = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule + +pprRuleBase :: RuleBase -> SDoc +pprRuleBase rules = pprUFM rules $ \rss -> + vcat [ pprRules (tidyRules emptyTidyEnv rs) + | rs <- rss ] + +{- +************************************************************************ +* * + Matching +* * +************************************************************************ +-} + +-- | The main rule matching function. Attempts to apply all (active) +-- supplied rules to this instance of an application in a given +-- context, returning the rule applied and the resulting expression if +-- successful. +lookupRule :: DynFlags -> InScopeEnv + -> (Activation -> Bool) -- When rule is active + -> Id -> [CoreExpr] + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) + +-- See Note [Extra args in rule matching] +-- See comments on matchRule +lookupRule dflags in_scope is_active fn args rules + = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ + case go [] rules of + [] -> Nothing + (m:ms) -> Just (findBest (fn,args') m ms) + where + rough_args = map roughTopName args + + -- Strip ticks from arguments, see note [Tick annotations in RULE + -- matching]. We only collect ticks if a rule actually matches - + -- this matters for performance tests. + args' = map (stripTicksTopE tickishFloatable) args + ticks = concatMap (stripTicksTopT tickishFloatable) args + + go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] + go ms [] = ms + go ms (r:rs) + | Just e <- matchRule dflags in_scope is_active fn args' rough_args r + = go ((r,mkTicks ticks e):ms) rs + | otherwise + = -- pprTrace "match failed" (ppr r $$ ppr args $$ + -- ppr [ (arg_id, unfoldingTemplate unf) + -- | Var arg_id <- args + -- , let unf = idUnfolding arg_id + -- , isCheapUnfolding unf] ) + go ms rs + +findBest :: (Id, [CoreExpr]) + -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) +-- All these pairs matched the expression +-- Return the pair the most specific rule +-- The (fn,args) is just for overlap reporting + +findBest _ (rule,ans) [] = (rule,ans) +findBest target (rule1,ans1) ((rule2,ans2):prs) + | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs + | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs + | debugIsOn = let pp_rule rule + = ifPprDebug (ppr rule) + (doubleQuotes (ftext (ruleName rule))) + in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" + (vcat [ whenPprDebug $ + text "Expression to match:" <+> ppr fn + <+> sep (map ppr args) + , text "Rule 1:" <+> pp_rule rule1 + , text "Rule 2:" <+> pp_rule rule2]) $ + findBest target (rule1,ans1) prs + | otherwise = findBest target (rule1,ans1) prs + where + (fn,args) = target + +isMoreSpecific :: CoreRule -> CoreRule -> Bool +-- This tests if one rule is more specific than another +-- We take the view that a BuiltinRule is less specific than +-- anything else, because we want user-define rules to "win" +-- In particular, class ops have a built-in rule, but we +-- any user-specific rules to win +-- eg (#4397) +-- truncate :: (RealFrac a, Integral b) => a -> b +-- {-# RULES "truncate/Double->Int" truncate = double2Int #-} +-- double2Int :: Double -> Int +-- We want the specific RULE to beat the built-in class-op rule +isMoreSpecific (BuiltinRule {}) _ = False +isMoreSpecific (Rule {}) (BuiltinRule {}) = True +isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) + (Rule { ru_bndrs = bndrs2, ru_args = args2 + , ru_name = rule_name2, ru_rhs = rhs }) + = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1 rhs) + where + id_unfolding_fun _ = NoUnfolding -- Don't expand in templates + in_scope = mkInScopeSet (mkVarSet bndrs1) + -- Actually we should probably include the free vars + -- of rule1's args, but I can't be bothered + +noBlackList :: Activation -> Bool +noBlackList _ = False -- Nothing is black listed + +{- +Note [Extra args in rule matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find a matching rule, we return (Just (rule, rhs)), +but the rule firing has only consumed as many of the input args +as the ruleArity says. It's up to the caller to keep track +of any left-over args. E.g. if you call + lookupRule ... f [e1, e2, e3] +and it returns Just (r, rhs), where r has ruleArity 2 +then the real rewrite is + f e1 e2 e3 ==> rhs e3 + +You might think it'd be cleaner for lookupRule to deal with the +leftover arguments, by applying 'rhs' to them, but the main call +in the Simplifier works better as it is. Reason: the 'args' passed +to lookupRule are the result of a lazy substitution +-} + +------------------------------------ +matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) + -> Id -> [CoreExpr] -> [Maybe Name] + -> CoreRule -> Maybe CoreExpr + +-- If (matchRule rule args) returns Just (name,rhs) +-- then (f args) matches the rule, and the corresponding +-- rewritten RHS is rhs +-- +-- The returned expression is occurrence-analysed +-- +-- Example +-- +-- The rule +-- forall f g x. map f (map g x) ==> map (f . g) x +-- is stored +-- CoreRule "map/map" +-- [f,g,x] -- tpl_vars +-- [f,map g x] -- tpl_args +-- map (f.g) x) -- rhs +-- +-- Then the call: matchRule the_rule [e1,map e2 e3] +-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) +-- +-- Any 'surplus' arguments in the input are simply put on the end +-- of the output. + +matchRule dflags rule_env _is_active fn args _rough_args + (BuiltinRule { ru_try = match_fn }) +-- Built-in rules can't be switched off, it seems + = case match_fn dflags rule_env fn args of + Nothing -> Nothing + Just expr -> Just expr + +matchRule _ in_scope is_active _ args rough_args + (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops + , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) + | not (is_active act) = Nothing + | ruleCantMatch tpl_tops rough_args = Nothing + | otherwise = matchN in_scope rule_name tpl_vars tpl_args args rhs + +--------------------------------------- +matchN :: InScopeEnv + -> RuleName -> [Var] -> [CoreExpr] + -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template + -> Maybe CoreExpr +-- For a given match template and context, find bindings to wrap around +-- the entire result and what should be substituted for each template variable. +-- Fail if there are two few actual arguments from the target to match the template + +matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs + = do { rule_subst <- go init_menv emptyRuleSubst tmpl_es target_es + ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) + (mkEmptyTCvSubst in_scope) $ + tmpl_vars `zip` tmpl_vars1 + bind_wrapper = rs_binds rule_subst + -- Floated bindings; see Note [Matching lets] + ; return (bind_wrapper $ + mkLams tmpl_vars rhs `mkApps` matched_es) } + where + (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars + -- See Note [Cloning the template binders] + + init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1 + , rv_lcl = init_rn_env + , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) + , rv_unf = id_unf } + + go _ subst [] _ = Just subst + go _ _ _ [] = Nothing -- Fail if too few actual args + go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e + ; go menv subst1 ts es } + + lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr) + -- Need to return a RuleSubst solely for the benefit of mk_fake_ty + lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) + tcv_subst (tmpl_var, tmpl_var1) + | isId tmpl_var1 + = case lookupVarEnv id_subst tmpl_var1 of + Just e | Coercion co <- e + -> (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) + | otherwise + -> (tcv_subst, e) + Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1 + , let co = Coercion.substCo tcv_subst refl_co + -> -- See Note [Unbound RULE binders] + (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co) + | otherwise + -> unbound tmpl_var + + | otherwise + = (Type.extendTvSubst tcv_subst tmpl_var1 ty', Type ty') + where + ty' = case lookupVarEnv tv_subst tmpl_var1 of + Just ty -> ty + Nothing -> fake_ty -- See Note [Unbound RULE binders] + fake_ty = anyTypeOfKind (Type.substTy tcv_subst (tyVarKind tmpl_var1)) + -- This substitution is the sole reason we accumulate + -- TCvSubst in lookup_tmpl + + unbound tmpl_var + = pprPanic "Template variable unbound in rewrite rule" $ + vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) + , text "Rule" <+> pprRuleName rule_name + , text "Rule bndrs:" <+> ppr tmpl_vars + , text "LHS args:" <+> ppr tmpl_es + , text "Actual args:" <+> ppr target_es ] + + +{- Note [Unbound RULE binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be the case that the binder in a rule is not actually +bound on the LHS: + +* Type variables. Type synonyms with phantom args can give rise to + unbound template type variables. Consider this (#10689, + simplCore/should_compile/T10689): + + type Foo a b = b + + f :: Eq a => a -> Bool + f x = x==x + + {-# RULES "foo" forall (x :: Foo a Char). f x = True #-} + finkle = f 'c' + + The rule looks like + forall (a::*) (d::Eq Char) (x :: Foo a Char). + f (Foo a Char) d x = True + + Matching the rule won't bind 'a', and legitimately so. We fudge by + pretending that 'a' is bound to (Any :: *). + +* Coercion variables. On the LHS of a RULE for a local binder + we might have + RULE forall (c :: a~b). f (x |> c) = e + Now, if that binding is inlined, so that a=b=Int, we'd get + RULE forall (c :: Int~Int). f (x |> c) = e + and now when we simplify the LHS (Simplify.simplRule) we + optCoercion (look at the CoVarCo case) will turn that 'c' into Refl: + RULE forall (c :: Int~Int). f (x |> <Int>) = e + and then perhaps drop it altogether. Now 'c' is unbound. + + It's tricky to be sure this never happens, so instead I + say it's OK to have an unbound coercion binder in a RULE + provided its type is (c :: t~t). Then, when the RULE + fires we can substitute <t> for c. + + This actually happened (in a RULE for a local function) + in #13410, and also in test T10602. + +Note [Cloning the template binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following match (example 1): + Template: forall x. f x + Target: f (x+1) +This should succeed, because the template variable 'x' has nothing to +do with the 'x' in the target. + +Likewise this one (example 2): + Template: forall x. f (\x.x) + Target: f (\y.y) + +We achieve this simply by using rnBndrL to clone the template +binders if they are already in scope. + +------ Historical note ------- +At one point I tried simply adding the template binders to the +in-scope set /without/ cloning them, but that failed in a horribly +obscure way in #14777. Problem was that during matching we look +up target-term variables in the in-scope set (see Note [Lookup +in-scope]). If a target-term variable happens to name-clash with a +template variable, that lookup will find the template variable, which +is /utterly/ bogus. In #14777, this transformed a term variable +into a type variable, and then crashed when we wanted its idInfo. +------ End of historical note ------- + + +************************************************************************ +* * + The main matcher +* * +********************************************************************* -} + +-- * The domain of the TvSubstEnv and IdSubstEnv are the template +-- variables passed into the match. +-- +-- * The BindWrapper in a RuleSubst are the bindings floated out +-- from nested matches; see the Let case of match, below +-- +data RuleMatchEnv + = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings* + -- (lambda/case) + , rv_tmpls :: VarSet -- Template variables + -- (after applying envL of rv_lcl) + , rv_fltR :: Subst -- Renamings for floated let-bindings + -- (domain disjoint from envR of rv_lcl) + -- See Note [Matching lets] + , rv_unf :: IdUnfoldingFun + } + +rvInScopeEnv :: RuleMatchEnv -> InScopeEnv +rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) + +data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the + , rs_id_subst :: IdSubstEnv -- template variables + , rs_binds :: BindWrapper -- Floated bindings + , rs_bndrs :: VarSet -- Variables bound by floated lets + } + +type BindWrapper = CoreExpr -> CoreExpr + -- See Notes [Matching lets] and [Matching cases] + -- we represent the floated bindings as a core-to-core function + +emptyRuleSubst :: RuleSubst +emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv + , rs_binds = \e -> e, rs_bndrs = emptyVarSet } + +-- At one stage I tried to match even if there are more +-- template args than real args. + +-- I now think this is probably a bad idea. +-- Should the template (map f xs) match (map g)? I think not. +-- For a start, in general eta expansion wastes work. +-- SLPJ July 99 + +match :: RuleMatchEnv + -> RuleSubst + -> CoreExpr -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst + +-- We look through certain ticks. See note [Tick annotations in RULE matching] +match renv subst e1 (Tick t e2) + | tickishFloatable t + = match renv subst' e1 e2 + where subst' = subst { rs_binds = rs_binds subst . mkTick t } +match _ _ e@Tick{} _ + = pprPanic "Tick in rule" (ppr e) + +-- See the notes with Unify.match, which matches types +-- Everything is very similar for terms + +-- Interesting examples: +-- Consider matching +-- \x->f against \f->f +-- When we meet the lambdas we must remember to rename f to f' in the +-- second expression. The RnEnv2 does that. +-- +-- Consider matching +-- forall a. \b->b against \a->3 +-- We must rename the \a. Otherwise when we meet the lambdas we +-- might substitute [a/b] in the template, and then erroneously +-- succeed in matching what looks like the template variable 'a' against 3. + +-- The Var case follows closely what happens in Unify.match +match renv subst (Var v1) e2 + = match_var renv subst v1 e2 + +match renv subst e1 (Var v2) -- Note [Expanding variables] + | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] + , Just e2' <- expandUnfolding_maybe (rv_unf renv v2') + = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' + where + v2' = lookupRnInScope rn_env v2 + rn_env = rv_lcl renv + -- Notice that we look up v2 in the in-scope set + -- See Note [Lookup in-scope] + -- No need to apply any renaming first (hence no rnOccR) + -- because of the not-inRnEnvR + +match renv subst e1 (Let bind e2) + | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ + not (isJoinBind bind) -- can't float join point out of argument position + , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] + = match (renv { rv_fltR = flt_subst' }) + (subst { rs_binds = rs_binds subst . Let bind' + , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) + e1 e2 + where + flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst) + (flt_subst', bind') = substBind flt_subst bind + new_bndrs = bindersOf bind' + +{- Disabled: see Note [Matching cases] below +match renv (tv_subst, id_subst, binds) e1 + (Case scrut case_bndr ty [(con, alt_bndrs, rhs)]) + | exprOkForSpeculation scrut -- See Note [Matching cases] + , okToFloat rn_env bndrs (exprFreeVars scrut) + = match (renv { me_env = rn_env' }) + (tv_subst, id_subst, binds . case_wrap) + e1 rhs + where + rn_env = me_env renv + rn_env' = extendRnInScopeList rn_env bndrs + bndrs = case_bndr : alt_bndrs + case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')] +-} + +match _ subst (Lit lit1) (Lit lit2) + | lit1 == lit2 + = Just subst + +match renv subst (App f1 a1) (App f2 a2) + = do { subst' <- match renv subst f1 f2 + ; match renv subst' a1 a2 } + +match renv subst (Lam x1 e1) e2 + | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2 + = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 + , rv_fltR = delBndr (rv_fltR renv) x2 } + subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } + in match renv' subst' e1 e2 + +match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) + = do { subst1 <- match_ty renv subst ty1 ty2 + ; subst2 <- match renv subst1 e1 e2 + ; let renv' = rnMatchBndr2 renv subst x1 x2 + ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted + } + +match renv subst (Type ty1) (Type ty2) + = match_ty renv subst ty1 ty2 +match renv subst (Coercion co1) (Coercion co2) + = match_co renv subst co1 co2 + +match renv subst (Cast e1 co1) (Cast e2 co2) + = do { subst1 <- match_co renv subst co1 co2 + ; match renv subst1 e1 e2 } + +-- Everything else fails +match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ + Nothing + +------------- +match_co :: RuleMatchEnv + -> RuleSubst + -> Coercion + -> Coercion + -> Maybe RuleSubst +match_co renv subst co1 co2 + | Just cv <- getCoVar_maybe co1 + = match_var renv subst cv (Coercion co2) + | Just (ty1, r1) <- isReflCo_maybe co1 + = do { (ty2, r2) <- isReflCo_maybe co2 + ; guard (r1 == r2) + ; match_ty renv subst ty1 ty2 } +match_co renv subst co1 co2 + | Just (tc1, cos1) <- splitTyConAppCo_maybe co1 + = case splitTyConAppCo_maybe co2 of + Just (tc2, cos2) + | tc1 == tc2 + -> match_cos renv subst cos1 cos2 + _ -> Nothing +match_co renv subst co1 co2 + | Just (arg1, res1) <- splitFunCo_maybe co1 + = case splitFunCo_maybe co2 of + Just (arg2, res2) + -> match_cos renv subst [arg1, res1] [arg2, res2] + _ -> Nothing +match_co _ _ _co1 _co2 + -- Currently just deals with CoVarCo, TyConAppCo and Refl +#if defined(DEBUG) + = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing +#else + = Nothing +#endif + +match_cos :: RuleMatchEnv + -> RuleSubst + -> [Coercion] + -> [Coercion] + -> Maybe RuleSubst +match_cos renv subst (co1:cos1) (co2:cos2) = + do { subst' <- match_co renv subst co1 co2 + ; match_cos renv subst' cos1 cos2 } +match_cos _ subst [] [] = Just subst +match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing + +------------- +rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv +rnMatchBndr2 renv subst x1 x2 + = renv { rv_lcl = rnBndr2 rn_env x1 x2 + , rv_fltR = delBndr (rv_fltR renv) x2 } + where + rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst) + -- Typically this is a no-op, but it may matter if + -- there are some floated let-bindings + +------------------------------------------ +match_alts :: RuleMatchEnv + -> RuleSubst + -> [CoreAlt] -- Template + -> [CoreAlt] -- Target + -> Maybe RuleSubst +match_alts _ subst [] [] + = return subst +match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) + | c1 == c2 + = do { subst1 <- match renv' subst r1 r2 + ; match_alts renv subst1 alts1 alts2 } + where + renv' = foldl' mb renv (vs1 `zip` vs2) + mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2 + +match_alts _ _ _ _ + = Nothing + +------------------------------------------ +okToFloat :: RnEnv2 -> VarSet -> Bool +okToFloat rn_env bind_fvs + = allVarSet not_captured bind_fvs + where + not_captured fv = not (inRnEnvR rn_env fv) + +------------------------------------------ +match_var :: RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst +match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) + subst v1 e2 + | v1' `elemVarSet` tmpls + = match_tmpl_var renv subst v1' e2 + + | otherwise -- v1' is not a template variable; check for an exact match with e2 + = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR + Var v2 | v1' == rnOccR rn_env v2 + -> Just subst + + | Var v2' <- lookupIdSubst (text "match_var") flt_env v2 + , v1' == v2' + -> Just subst + + _ -> Nothing + + where + v1' = rnOccL rn_env v1 + -- If the template is + -- forall x. f x (\x -> x) = ... + -- Then the x inside the lambda isn't the + -- template x, so we must rename first! + +------------------------------------------ +match_tmpl_var :: RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst + +match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) + subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) + v1' e2 + | any (inRnEnvR rn_env) (exprFreeVarsList e2) + = Nothing -- Occurs check failure + -- e.g. match forall a. (\x-> a x) against (\y. y y) + + | Just e1' <- lookupVarEnv id_subst v1' + = if eqExpr (rnInScopeSet rn_env) e1' e2' + then Just subst + else Nothing + + | otherwise + = -- Note [Matching variable types] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- However, we must match the *types*; e.g. + -- forall (c::Char->Int) (x::Char). + -- f (c x) = "RULE FIRED" + -- We must only match on args that have the right type + -- It's actually quite difficult to come up with an example that shows + -- you need type matching, esp since matching is left-to-right, so type + -- args get matched first. But it's possible (e.g. simplrun008) and + -- this is the Right Thing to do + do { subst' <- match_ty renv subst (idType v1') (exprType e2) + ; return (subst' { rs_id_subst = id_subst' }) } + where + -- e2' is the result of applying flt_env to e2 + e2' | isEmptyVarSet let_bndrs = e2 + | otherwise = substExpr (text "match_tmpl_var") flt_env e2 + + id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' + -- No further renaming to do on e2', + -- because no free var of e2' is in the rnEnvR of the envt + +------------------------------------------ +match_ty :: RuleMatchEnv + -> RuleSubst + -> Type -- Template + -> Type -- Target + -> Maybe RuleSubst +-- Matching Core types: use the matcher in TcType. +-- Notice that we treat newtypes as opaque. For example, suppose +-- we have a specialised version of a function at a newtype, say +-- newtype T = MkT Int +-- We only want to replace (f T) with f', not (f Int). + +match_ty renv subst ty1 ty2 + = do { tv_subst' + <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2 + ; return (subst { rs_tv_subst = tv_subst' }) } + where + tv_subst = rs_tv_subst subst + +{- +Note [Expanding variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is another Very Important rule: if the term being matched is a +variable, we expand it so long as its unfolding is "expandable". (Its +occurrence information is not necessarily up to date, so we don't use +it.) By "expandable" we mean a WHNF or a "constructor-like" application. +This is the key reason for "constructor-like" Ids. If we have + {-# NOINLINE [1] CONLIKE g #-} + {-# RULE f (g x) = h x #-} +then in the term + let v = g 3 in ....(f v).... +we want to make the rule fire, to replace (f v) with (h 3). + +Note [Do not expand locally-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* expand locally-bound variables, else there's a worry that the +unfolding might mention variables that are themselves renamed. +Example + case x of y { (p,q) -> ...y... } +Don't expand 'y' to (p,q) because p,q might themselves have been +renamed. Essentially we only expand unfoldings that are "outside" +the entire match. + +Hence, (a) the guard (not (isLocallyBoundR v2)) + (b) when we expand we nuke the renaming envt (nukeRnEnvR). + +Note [Tick annotations in RULE matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We used to unconditionally look through Notes in both template and +expression being matched. This is actually illegal for counting or +cost-centre-scoped ticks, because we have no place to put them without +changing entry counts and/or costs. So now we just fail the match in +these cases. + +On the other hand, where we are allowed to insert new cost into the +tick scope, we can float them upwards to the rule application site. + +cf Note [Notes in call patterns] in SpecConstr + +Note [Matching lets] +~~~~~~~~~~~~~~~~~~~~ +Matching a let-expression. Consider + RULE forall x. f (g x) = <rhs> +and target expression + f (let { w=R } in g E)) +Then we'd like the rule to match, to generate + let { w=R } in (\x. <rhs>) E +In effect, we want to float the let-binding outward, to enable +the match to happen. This is the WHOLE REASON for accumulating +bindings in the RuleSubst + +We can only do this if the free variables of R are not bound by the +part of the target expression outside the let binding; e.g. + f (\v. let w = v+1 in g E) +Here we obviously cannot float the let-binding for w. Hence the +use of okToFloat. + +There are a couple of tricky points. + (a) What if floating the binding captures a variable? + f (let v = x+1 in v) v + --> NOT! + let v = x+1 in f (x+1) v + + (b) What if two non-nested let bindings bind the same variable? + f (let v = e1 in b1) (let v = e2 in b2) + --> NOT! + let v = e1 in let v = e2 in (f b2 b2) + See testsuite test "RuleFloatLet". + +Our cunning plan is this: + * Along with the growing substitution for template variables + we maintain a growing set of floated let-bindings (rs_binds) + plus the set of variables thus bound. + + * The RnEnv2 in the MatchEnv binds only the local binders + in the term (lambdas, case) + + * When we encounter a let in the term to be matched, we + check that does not mention any locally bound (lambda, case) + variables. If so we fail + + * We use GHC.Core.Subst.substBind to freshen the binding, using an + in-scope set that is the original in-scope variables plus the + rs_bndrs (currently floated let-bindings). So in (a) above + we'll freshen the 'v' binding; in (b) above we'll freshen + the *second* 'v' binding. + + * We apply that freshening substitution, in a lexically-scoped + way to the term, although lazily; this is the rv_fltR field. + + +Note [Matching cases] +~~~~~~~~~~~~~~~~~~~~~ +{- NOTE: This idea is currently disabled. It really only works if + the primops involved are OkForSpeculation, and, since + they have side effects readIntOfAddr and touch are not. + Maybe we'll get back to this later . -} + +Consider + f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + I# n# } } ) +This happened in a tight loop generated by stream fusion that +Roman encountered. We'd like to treat this just like the let +case, because the primops concerned are ok-for-speculation. +That is, we'd like to behave as if it had been + case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + f (I# n# } } ) + +Note [Lookup in-scope] +~~~~~~~~~~~~~~~~~~~~~~ +Consider this example + foo :: Int -> Maybe Int -> Int + foo 0 (Just n) = n + foo m (Just n) = foo (m-n) (Just n) + +SpecConstr sees this fragment: + + case w_smT of wild_Xf [Just A] { + Data.Maybe.Nothing -> lvl_smf; + Data.Maybe.Just n_acT [Just S(L)] -> + case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> + $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + }}; + +and correctly generates the rule + + RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# + sc_snn :: GHC.Prim.Int#} + $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) + = $s$wfoo_sno y_amr sc_snn ;] + +BUT we must ensure that this rule matches in the original function! +Note that the call to $wfoo is + $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + +During matching we expand wild_Xf to (Just n_acT). But then we must also +expand n_acT to (I# y_amr). And we can only do that if we look up n_acT +in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding +at all. + +That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' +is so important. + + +************************************************************************ +* * + Rule-check the program +* * +************************************************************************ + + We want to know what sites have rules that could have fired but didn't. + This pass runs over the tree (without changing it) and reports such. +-} + +-- | Report partial matches for rules beginning with the specified +-- string for the purposes of error reporting +ruleCheckProgram :: CompilerPhase -- ^ Rule activation test + -> String -- ^ Rule pattern + -> (Id -> [CoreRule]) -- ^ Rules for an Id + -> CoreProgram -- ^ Bindings to check in + -> SDoc -- ^ Resulting check message +ruleCheckProgram phase rule_pat rules binds + | isEmptyBag results + = text "Rule check results: no rule application sites" + | otherwise + = vcat [text "Rule check results:", + line, + vcat [ p $$ line | p <- bagToList results ] + ] + where + env = RuleCheckEnv { rc_is_active = isActive phase + , rc_id_unf = idUnfolding -- Not quite right + -- Should use activeUnfolding + , rc_pattern = rule_pat + , rc_rules = rules } + results = unionManyBags (map (ruleCheckBind env) binds) + line = text (replicate 20 '-') + +data RuleCheckEnv = RuleCheckEnv { + rc_is_active :: Activation -> Bool, + rc_id_unf :: IdUnfoldingFun, + rc_pattern :: String, + rc_rules :: Id -> [CoreRule] +} + +ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc + -- The Bag returned has one SDoc for each call site found +ruleCheckBind env (NonRec _ r) = ruleCheck env r +ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] + +ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc +ruleCheck _ (Var _) = emptyBag +ruleCheck _ (Lit _) = emptyBag +ruleCheck _ (Type _) = emptyBag +ruleCheck _ (Coercion _) = emptyBag +ruleCheck env (App f a) = ruleCheckApp env (App f a) [] +ruleCheck env (Tick _ e) = ruleCheck env e +ruleCheck env (Cast e _) = ruleCheck env e +ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e +ruleCheck env (Lam _ e) = ruleCheck env e +ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` + unionManyBags [ruleCheck env r | (_,_,r) <- as] + +ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc +ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) +ruleCheckApp env (Var f) as = ruleCheckFun env f as +ruleCheckApp env other _ = ruleCheck env other + +ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc +-- Produce a report for all rules matching the predicate +-- saying why it doesn't match the specified application + +ruleCheckFun env fn args + | null name_match_rules = emptyBag + | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) + where + name_match_rules = filter match (rc_rules env fn) + match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) + +ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help env fn args rules + = -- The rules match the pattern, so we want to print something + vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), + vcat (map check_rule rules)] + where + n_args = length args + i_args = args `zip` [1::Int ..] + rough_args = map roughTopName args + + check_rule rule = sdocWithDynFlags $ \dflags -> + rule_herald rule <> colon <+> rule_info dflags rule + + rule_herald (BuiltinRule { ru_name = name }) + = text "Builtin rule" <+> doubleQuotes (ftext name) + rule_herald (Rule { ru_name = name }) + = text "Rule" <+> doubleQuotes (ftext name) + + rule_info dflags rule + | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env) + noBlackList fn args rough_args rule + = text "matches (which is very peculiar!)" + + rule_info _ (BuiltinRule {}) = text "does not match" + + rule_info _ (Rule { ru_act = act, + ru_bndrs = rule_bndrs, ru_args = rule_args}) + | not (rc_is_active env act) = text "active only in later phase" + | n_args < n_rule_args = text "too few arguments" + | n_mismatches == n_rule_args = text "no arguments match" + | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" + | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" + where + n_rule_args = length rule_args + n_mismatches = length mismatches + mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, + not (isJust (match_fn rule_arg arg))] + + lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars + match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg + where + in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) + renv = RV { rv_lcl = mkRnEnv2 in_scope + , rv_tmpls = mkVarSet rule_bndrs + , rv_fltR = mkEmptySubst in_scope + , rv_unf = rc_id_unf env } diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs new file mode 100644 index 0000000000..5c600296e0 --- /dev/null +++ b/compiler/GHC/Core/Seq.hs @@ -0,0 +1,115 @@ +-- | +-- Various utilities for forcing Core structures +-- +-- It can often be useful to force various parts of the AST. This module +-- provides a number of @seq@-like functions to accomplish this. + +module GHC.Core.Seq ( + -- * Utilities for forcing Core structures + seqExpr, seqExprs, seqUnfolding, seqRules, + megaSeqIdInfo, seqRuleInfo, seqBinds, + ) where + +import GhcPrelude + +import GHC.Core +import IdInfo +import Demand( seqDemand, seqStrictSig ) +import Cpr( seqCprSig ) +import BasicTypes( seqOccInfo ) +import VarSet( seqDVarSet ) +import Var( varType, tyVarKind ) +import Type( seqType, isTyVar ) +import Coercion( seqCo ) +import Id( Id, idInfo ) + +-- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the +-- compiler +megaSeqIdInfo :: IdInfo -> () +megaSeqIdInfo info + = seqRuleInfo (ruleInfo info) `seq` + +-- Omitting this improves runtimes a little, presumably because +-- some unfoldings are not calculated at all +-- seqUnfolding (unfoldingInfo info) `seq` + + seqDemand (demandInfo info) `seq` + seqStrictSig (strictnessInfo info) `seq` + seqCprSig (cprInfo info) `seq` + seqCaf (cafInfo info) `seq` + seqOneShot (oneShotInfo info) `seq` + seqOccInfo (occInfo info) + +seqOneShot :: OneShotInfo -> () +seqOneShot l = l `seq` () + +seqRuleInfo :: RuleInfo -> () +seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqDVarSet fvs + +seqCaf :: CafInfo -> () +seqCaf c = c `seq` () + +seqRules :: [CoreRule] -> () +seqRules [] = () +seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) + = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules +seqRules (BuiltinRule {} : rules) = seqRules rules + +seqExpr :: CoreExpr -> () +seqExpr (Var v) = v `seq` () +seqExpr (Lit lit) = lit `seq` () +seqExpr (App f a) = seqExpr f `seq` seqExpr a +seqExpr (Lam b e) = seqBndr b `seq` seqExpr e +seqExpr (Let b e) = seqBind b `seq` seqExpr e +seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as +seqExpr (Cast e co) = seqExpr e `seq` seqCo co +seqExpr (Tick n e) = seqTickish n `seq` seqExpr e +seqExpr (Type t) = seqType t +seqExpr (Coercion co) = seqCo co + +seqExprs :: [CoreExpr] -> () +seqExprs [] = () +seqExprs (e:es) = seqExpr e `seq` seqExprs es + +seqTickish :: Tickish Id -> () +seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () +seqTickish HpcTick{} = () +seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids +seqTickish SourceNote{} = () + +seqBndr :: CoreBndr -> () +seqBndr b | isTyVar b = seqType (tyVarKind b) + | otherwise = seqType (varType b) `seq` + megaSeqIdInfo (idInfo b) + +seqBndrs :: [CoreBndr] -> () +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs + +seqBinds :: [Bind CoreBndr] -> () +seqBinds bs = foldr (seq . seqBind) () bs + +seqBind :: Bind CoreBndr -> () +seqBind (NonRec b e) = seqBndr b `seq` seqExpr e +seqBind (Rec prs) = seqPairs prs + +seqPairs :: [(CoreBndr, CoreExpr)] -> () +seqPairs [] = () +seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs + +seqAlts :: [CoreAlt] -> () +seqAlts [] = () +seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts + +seqUnfolding :: Unfolding -> () +seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, + uf_is_value = b1, uf_is_work_free = b2, + uf_expandable = b3, uf_is_conlike = b4, + uf_guidance = g}) + = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g + +seqUnfolding _ = () + +seqGuidance :: UnfoldingGuidance -> () +seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () +seqGuidance _ = () diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs new file mode 100644 index 0000000000..f9665140b1 --- /dev/null +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -0,0 +1,1475 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +module GHC.Core.SimpleOpt ( + -- ** Simple expression optimiser + simpleOptPgm, simpleOptExpr, simpleOptExprWith, + + -- ** Join points + joinPointBinding_maybe, joinPointBindings_maybe, + + -- ** Predicates on expressions + exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, + + -- ** Coercions and casts + pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core.Arity( etaExpandToJoinPoint ) + +import GHC.Core +import GHC.Core.Subst +import GHC.Core.Utils +import GHC.Core.FVs +import {-# SOURCE #-} GHC.Core.Unfold( mkUnfolding ) +import GHC.Core.Make ( FloatBind(..) ) +import GHC.Core.Ppr ( pprCoreBindings, pprRules ) +import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) +import Literal ( Literal(LitString) ) +import Id +import IdInfo ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) +import Var ( isNonCoVarId ) +import VarSet +import VarEnv +import DataCon +import Demand( etaExpandStrictSig ) +import OptCoercion ( optCoercion ) +import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import Coercion hiding ( substCo, substCoVarBndr ) +import TyCon ( tyConArity ) +import TysWiredIn +import PrelNames +import BasicTypes +import Module ( Module ) +import ErrUtils +import GHC.Driver.Session +import Outputable +import Pair +import Util +import Maybes ( orElse ) +import FastString +import Data.List +import qualified Data.ByteString as BS + +{- +************************************************************************ +* * + The Simple Optimiser +* * +************************************************************************ + +Note [The simple optimiser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simple optimiser is a lightweight, pure (non-monadic) function +that rapidly does a lot of simple optimisations, including + + - inlining things that occur just once, + or whose RHS turns out to be trivial + - beta reduction + - case of known constructor + - dead code elimination + +It does NOT do any call-site inlining; it only inlines a function if +it can do so unconditionally, dropping the binding. It thereby +guarantees to leave no un-reduced beta-redexes. + +It is careful to follow the guidance of "Secrets of the GHC inliner", +and in particular the pre-inline-unconditionally and +post-inline-unconditionally story, to do effective beta reduction on +functions called precisely once, without repeatedly optimising the same +expression. In fact, the simple optimiser is a good example of this +little dance in action; the full Simplifier is a lot more complicated. + +-} + +simpleOptExpr :: DynFlags -> CoreExpr -> CoreExpr +-- See Note [The simple optimiser] +-- Do simple optimisation on an expression +-- The optimisation is very straightforward: just +-- inline non-recursive bindings that are used only once, +-- or where the RHS is trivial +-- +-- We also inline bindings that bind a Eq# box: see +-- See Note [Getting the map/coerce RULE to work]. +-- +-- Also we convert functions to join points where possible (as +-- the occurrence analyser does most of the work anyway). +-- +-- The result is NOT guaranteed occurrence-analysed, because +-- in (let x = y in ....) we substitute for x; so y's occ-info +-- may change radically + +simpleOptExpr dflags expr + = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) + simpleOptExprWith dflags init_subst expr + where + init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) + -- It's potentially important to make a proper in-scope set + -- Consider let x = ..y.. in \y. ...x... + -- Then we should remember to clone y before substituting + -- for x. It's very unlikely to occur, because we probably + -- won't *be* substituting for x if it occurs inside a + -- lambda. + -- + -- It's a bit painful to call exprFreeVars, because it makes + -- three passes instead of two (occ-anal, and go) + +simpleOptExprWith :: DynFlags -> Subst -> InExpr -> OutExpr +-- See Note [The simple optimiser] +simpleOptExprWith dflags subst expr + = simple_opt_expr init_env (occurAnalyseExpr expr) + where + init_env = SOE { soe_dflags = dflags + , soe_inl = emptyVarEnv + , soe_subst = subst } + +---------------------- +simpleOptPgm :: DynFlags -> Module + -> CoreProgram -> [CoreRule] + -> IO (CoreProgram, [CoreRule]) +-- See Note [The simple optimiser] +simpleOptPgm dflags this_mod binds rules + = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + FormatCore (pprCoreBindings occ_anald_binds $$ pprRules rules ); + + ; return (reverse binds', rules') } + where + occ_anald_binds = occurAnalysePgm this_mod + (\_ -> True) {- All unfoldings active -} + (\_ -> False) {- No rules active -} + rules binds + + (final_env, binds') = foldl' do_one (emptyEnv dflags, []) occ_anald_binds + final_subst = soe_subst final_env + + rules' = substRulesForImportedIds final_subst rules + -- We never unconditionally inline into rules, + -- hence paying just a substitution + + do_one (env, binds') bind + = case simple_opt_bind env bind TopLevel of + (env', Nothing) -> (env', binds') + (env', Just bind') -> (env', bind':binds') + +-- In these functions the substitution maps InVar -> OutExpr + +---------------------- +type SimpleClo = (SimpleOptEnv, InExpr) + +data SimpleOptEnv + = SOE { soe_dflags :: DynFlags + , soe_inl :: IdEnv SimpleClo + -- Deals with preInlineUnconditionally; things + -- that occur exactly once and are inlined + -- without having first been simplified + + , soe_subst :: Subst + -- Deals with cloning; includes the InScopeSet + } + +instance Outputable SimpleOptEnv where + ppr (SOE { soe_inl = inl, soe_subst = subst }) + = text "SOE {" <+> vcat [ text "soe_inl =" <+> ppr inl + , text "soe_subst =" <+> ppr subst ] + <+> text "}" + +emptyEnv :: DynFlags -> SimpleOptEnv +emptyEnv dflags + = SOE { soe_dflags = dflags + , soe_inl = emptyVarEnv + , soe_subst = emptySubst } + +soeZapSubst :: SimpleOptEnv -> SimpleOptEnv +soeZapSubst env@(SOE { soe_subst = subst }) + = env { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst } + +soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv +-- Take in-scope set from env1, and the rest from env2 +soeSetInScope (SOE { soe_subst = subst1 }) + env2@(SOE { soe_subst = subst2 }) + = env2 { soe_subst = setInScope subst2 (substInScope subst1) } + +--------------- +simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr +simple_opt_clo env (e_env, e) + = simple_opt_expr (soeSetInScope env e_env) e + +simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr +simple_opt_expr env expr + = go expr + where + subst = soe_subst env + in_scope = substInScope subst + in_scope_env = (in_scope, simpleUnfoldingFun) + + go (Var v) + | Just clo <- lookupVarEnv (soe_inl env) v + = simple_opt_clo env clo + | otherwise + = lookupIdSubst (text "simpleOptExpr") (soe_subst env) v + + go (App e1 e2) = simple_app env e1 [(env,e2)] + go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (optCoercion (soe_dflags env) (getTCvSubst subst) co) + go (Lit lit) = Lit lit + go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) + go (Cast e co) | isReflCo co' = go e + | otherwise = Cast (go e) co' + where + co' = optCoercion (soe_dflags env) (getTCvSubst subst) co + + go (Let bind body) = case simple_opt_bind env bind NotTopLevel of + (env', Nothing) -> simple_opt_expr env' body + (env', Just bind) -> Let bind (simple_opt_expr env' body) + + go lam@(Lam {}) = go_lam env [] lam + go (Case e b ty as) + -- See Note [Getting the map/coerce RULE to work] + | isDeadBinder b + , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e' + -- We don't need to be concerned about floats when looking for coerce. + , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as + = case altcon of + DEFAULT -> go rhs + _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs + where + (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $ + zipEqual "simpleOptExpr" bs es + + -- Note [Getting the map/coerce RULE to work] + | isDeadBinder b + , [(DEFAULT, _, rhs)] <- as + , isCoVarType (varType b) + , (Var fun, _args) <- collectArgs e + , fun `hasKey` coercibleSCSelIdKey + -- without this last check, we get #11230 + = go rhs + + | otherwise + = Case e' b' (substTy subst ty) + (map (go_alt env') as) + where + e' = go e + (env', b') = subst_opt_bndr env b + + ---------------------- + go_alt env (con, bndrs, rhs) + = (con, bndrs', simple_opt_expr env' rhs) + where + (env', bndrs') = subst_opt_bndrs env bndrs + + ---------------------- + -- go_lam tries eta reduction + go_lam env bs' (Lam b e) + = go_lam env' (b':bs') e + where + (env', b') = subst_opt_bndr env b + go_lam env bs' e + | Just etad_e <- tryEtaReduce bs e' = etad_e + | otherwise = mkLams bs e' + where + bs = reverse bs' + e' = simple_opt_expr env e + +---------------------- +-- simple_app collects arguments for beta reduction +simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr + +simple_app env (Var v) as + | Just (env', e) <- lookupVarEnv (soe_inl env) v + = simple_app (soeSetInScope env env') e as + + | let unf = idUnfolding v + , isCompulsoryUnfolding (idUnfolding v) + , isAlwaysActive (idInlineActivation v) + -- See Note [Unfold compulsory unfoldings in LHSs] + = simple_app (soeZapSubst env) (unfoldingTemplate unf) as + + | otherwise + , let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v + = finish_app env out_fn as + +simple_app env (App e1 e2) as + = simple_app env e1 ((env, e2) : as) + +simple_app env (Lam b e) (a:as) + = wrapLet mb_pr (simple_app env' e as) + where + (env', mb_pr) = simple_bind_pair env b Nothing a NotTopLevel + +simple_app env (Tick t e) as + -- Okay to do "(Tick t e) x ==> Tick t (e x)"? + | t `tickishScopesLike` SoftScope + = mkTick t $ simple_app env e as + +-- (let x = e in b) a1 .. an => let x = e in (b a1 .. an) +-- The let might appear there as a result of inlining +-- e.g. let f = let x = e in b +-- in f a1 a2 +-- (#13208) +-- However, do /not/ do this transformation for join points +-- See Note [simple_app and join points] +simple_app env (Let bind body) args + = case simple_opt_bind env bind NotTopLevel of + (env', Nothing) -> simple_app env' body args + (env', Just bind') + | isJoinBind bind' -> finish_app env expr' args + | otherwise -> Let bind' (simple_app env' body args) + where + expr' = Let bind' (simple_opt_expr env' body) + +simple_app env e as + = finish_app env (simple_opt_expr env e) as + +finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr +finish_app _ fun [] + = fun +finish_app env fun (arg:args) + = finish_app env (App fun (simple_opt_clo env arg)) args + +---------------------- +simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag + -> (SimpleOptEnv, Maybe OutBind) +simple_opt_bind env (NonRec b r) top_level + = (env', case mb_pr of + Nothing -> Nothing + Just (b,r) -> Just (NonRec b r)) + where + (b', r') = joinPointBinding_maybe b r `orElse` (b, r) + (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') top_level + +simple_opt_bind env (Rec prs) top_level + = (env'', res_bind) + where + res_bind = Just (Rec (reverse rev_prs')) + prs' = joinPointBindings_maybe prs `orElse` prs + (env', bndrs') = subst_opt_bndrs env (map fst prs') + (env'', rev_prs') = foldl' do_pr (env', []) (prs' `zip` bndrs') + do_pr (env, prs) ((b,r), b') + = (env', case mb_pr of + Just pr -> pr : prs + Nothing -> prs) + where + (env', mb_pr) = simple_bind_pair env b (Just b') (env,r) top_level + +---------------------- +simple_bind_pair :: SimpleOptEnv + -> InVar -> Maybe OutVar + -> SimpleClo + -> TopLevelFlag + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) + -- (simple_bind_pair subst in_var out_rhs) + -- either extends subst with (in_var -> out_rhs) + -- or returns Nothing +simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) + in_bndr mb_out_bndr clo@(rhs_env, in_rhs) + top_level + | Type ty <- in_rhs -- let a::* = TYPE ty in <body> + , let out_ty = substTy (soe_subst rhs_env) ty + = ASSERT( isTyVar in_bndr ) + (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) + + | Coercion co <- in_rhs + , let out_co = optCoercion (soe_dflags env) (getTCvSubst (soe_subst rhs_env)) co + = ASSERT( isCoVar in_bndr ) + (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) + + | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) + -- The previous two guards got rid of tyvars and coercions + -- See Note [Core type and coercion invariant] in GHC.Core + pre_inline_unconditionally + = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing) + + | otherwise + = simple_out_bind_pair env in_bndr mb_out_bndr out_rhs + occ active stable_unf top_level + where + stable_unf = isStableUnfolding (idUnfolding in_bndr) + active = isAlwaysActive (idInlineActivation in_bndr) + occ = idOccInfo in_bndr + + out_rhs | Just join_arity <- isJoinId_maybe in_bndr + = simple_join_rhs join_arity + | otherwise + = simple_opt_clo env clo + + simple_join_rhs join_arity -- See Note [Preserve join-binding arity] + = mkLams join_bndrs' (simple_opt_expr env_body join_body) + where + env0 = soeSetInScope env rhs_env + (join_bndrs, join_body) = collectNBinders join_arity in_rhs + (env_body, join_bndrs') = subst_opt_bndrs env0 join_bndrs + + pre_inline_unconditionally :: Bool + pre_inline_unconditionally + | isExportedId in_bndr = False + | stable_unf = False + | not active = False -- Note [Inline prag in simplOpt] + | not (safe_to_inline occ) = False + | otherwise = True + + -- Unconditionally safe to inline + safe_to_inline :: OccInfo -> Bool + safe_to_inline IAmALoopBreaker{} = False + safe_to_inline IAmDead = True + safe_to_inline OneOcc{ occ_in_lam = NotInsideLam + , occ_one_br = InOneBranch } = True + safe_to_inline OneOcc{} = False + safe_to_inline ManyOccs{} = False + +------------------- +simple_out_bind :: TopLevelFlag + -> SimpleOptEnv + -> (InVar, OutExpr) + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) +simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) + | Type out_ty <- out_rhs + = ASSERT( isTyVar in_bndr ) + (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) + + | Coercion out_co <- out_rhs + = ASSERT( isCoVar in_bndr ) + (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) + + | otherwise + = simple_out_bind_pair env in_bndr Nothing out_rhs + (idOccInfo in_bndr) True False top_level + +------------------- +simple_out_bind_pair :: SimpleOptEnv + -> InId -> Maybe OutId -> OutExpr + -> OccInfo -> Bool -> Bool -> TopLevelFlag + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) +simple_out_bind_pair env in_bndr mb_out_bndr out_rhs + occ_info active stable_unf top_level + | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) + -- Type and coercion bindings are caught earlier + -- See Note [Core type and coercion invariant] + post_inline_unconditionally + = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs } + , Nothing) + + | otherwise + = ( env', Just (out_bndr, out_rhs) ) + where + (env', bndr1) = case mb_out_bndr of + Just out_bndr -> (env, out_bndr) + Nothing -> subst_opt_bndr env in_bndr + out_bndr = add_info env' in_bndr top_level out_rhs bndr1 + + post_inline_unconditionally :: Bool + post_inline_unconditionally + | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs] + | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally] + | not active = False -- in SimplUtils + | is_loop_breaker = False -- If it's a loop-breaker of any kind, don't inline + -- because it might be referred to "earlier" + | exprIsTrivial out_rhs = True + | coercible_hack = True + | otherwise = False + + is_loop_breaker = isWeakLoopBreaker occ_info + + -- See Note [Getting the map/coerce RULE to work] + coercible_hack | (Var fun, args) <- collectArgs out_rhs + , Just dc <- isDataConWorkId_maybe fun + , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey + = all exprIsTrivial args + | otherwise + = False + +{- Note [Exported Ids and trivial RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously do not want to unconditionally inline an Id that is exported. +In SimplUtils, Note [Top level and postInlineUnconditionally], we +explain why we don't inline /any/ top-level things unconditionally, even +trivial ones. But we do here! Why? In the simple optimiser + + * We do no rule rewrites + * We do no call-site inlining + +Those differences obviate the reasons for not inlining a trivial rhs, +and increase the benefit for doing so. So we unconditionally inline trivial +rhss here. + +Note [Preserve join-binding arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Be careful /not/ to eta-reduce the RHS of a join point, lest we lose +the join-point arity invariant. #15108 was caused by simplifying +the RHS with simple_opt_expr, which does eta-reduction. Solution: +simplify the RHS of a join point by simplifying under the lambdas +(which of course should be there). + +Note [simple_app and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general for let-bindings we can do this: + (let { x = e } in b) a ==> let { x = e } in b a + +But not for join points! For two reasons: + +- We would need to push the continuation into the RHS: + (join { j = e } in b) a ==> let { j' = e a } in b[j'/j] a + NB ----^^ + and also change the type of j, hence j'. + That's a bit sophisticated for the very simple optimiser. + +- We might end up with something like + join { j' = e a } in + (case blah of ) + ( True -> j' void# ) a + ( False -> blah ) + and now the call to j' doesn't look like a tail call, and + Lint may reject. I say "may" because this is /explicitly/ + allowed in the "Compiling without Continuations" paper + (Section 3, "Managing \Delta"). But GHC currently does not + allow this slightly-more-flexible form. See GHC.Core + Note [Join points are less general than the paper]. + +The simple thing to do is to disable this transformation +for join points in the simple optimiser + +Note [The Let-Unfoldings Invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A program has the Let-Unfoldings property iff: + +- For every let-bound variable f, whether top-level or nested, whether + recursive or not: + - Both the binding Id of f, and every occurrence Id of f, has an idUnfolding. + - For non-INLINE things, that unfolding will be f's right hand sids + - For INLINE things (which have a "stable" unfolding) that unfolding is + semantically equivalent to f's RHS, but derived from the original RHS of f + rather that its current RHS. + +Informally, we can say that in a program that has the Let-Unfoldings property, +all let-bound Id's have an explicit unfolding attached to them. + +Currently, the simplifier guarantees the Let-Unfoldings invariant for anything +it outputs. + +-} + +---------------------- +subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar]) +subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs + +subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar) +subst_opt_bndr env bndr + | isTyVar bndr = (env { soe_subst = subst_tv }, tv') + | isCoVar bndr = (env { soe_subst = subst_cv }, cv') + | otherwise = subst_opt_id_bndr env bndr + where + subst = soe_subst env + (subst_tv, tv') = substTyVarBndr subst bndr + (subst_cv, cv') = substCoVarBndr subst bndr + +subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) +-- Nuke all fragile IdInfo, unfolding, and RULES; it gets added back later by +-- add_info. +-- +-- Rather like SimplEnv.substIdBndr +-- +-- It's important to zap fragile OccInfo (which GHC.Core.Subst.substIdBndr +-- carefully does not do) because simplOptExpr invalidates it + +subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id + = (env { soe_subst = new_subst, soe_inl = new_inl }, new_id) + where + Subst in_scope id_subst tv_subst cv_subst = subst + + id1 = uniqAway in_scope old_id + id2 = setIdType id1 (substTy subst (idType old_id)) + new_id = zapFragileIdInfo id2 + -- Zaps rules, unfolding, and fragile OccInfo + -- The unfolding and rules will get added back later, by add_info + + new_in_scope = in_scope `extendInScopeSet` new_id + + no_change = new_id == old_id + + -- Extend the substitution if the unique has changed, + -- See the notes with substTyVarBndr for the delSubstEnv + new_id_subst + | no_change = delVarEnv id_subst old_id + | otherwise = extendVarEnv id_subst old_id (Var new_id) + + new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst + new_inl = delVarEnv inl old_id + +---------------------- +add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar +add_info env old_bndr top_level new_rhs new_bndr + | isTyVar old_bndr = new_bndr + | otherwise = lazySetIdInfo new_bndr new_info + where + subst = soe_subst env + dflags = soe_dflags env + old_info = idInfo old_bndr + + -- Add back in the rules and unfolding which were + -- removed by zapFragileIdInfo in subst_opt_id_bndr. + -- + -- See Note [The Let-Unfoldings Invariant] + new_info = idInfo new_bndr `setRuleInfo` new_rules + `setUnfoldingInfo` new_unfolding + + old_rules = ruleInfo old_info + new_rules = substSpec subst new_bndr old_rules + + old_unfolding = unfoldingInfo old_info + new_unfolding | isStableUnfolding old_unfolding + = substUnfolding subst old_unfolding + | otherwise + = unfolding_from_rhs + + unfolding_from_rhs = mkUnfolding dflags InlineRhs + (isTopLevel top_level) + False -- may be bottom or not + new_rhs + +simpleUnfoldingFun :: IdUnfoldingFun +simpleUnfoldingFun id + | isAlwaysActive (idInlineActivation id) = idUnfolding id + | otherwise = noUnfolding + +wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr +wrapLet Nothing body = body +wrapLet (Just (b,r)) body = Let (NonRec b r) body + +{- +Note [Inline prag in simplOpt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If there's an INLINE/NOINLINE pragma that restricts the phase in +which the binder can be inlined, we don't inline here; after all, +we don't know what phase we're in. Here's an example + + foo :: Int -> Int -> Int + {-# INLINE foo #-} + foo m n = inner m + where + {-# INLINE [1] inner #-} + inner m = m+n + + bar :: Int -> Int + bar n = foo n 1 + +When inlining 'foo' in 'bar' we want the let-binding for 'inner' +to remain visible until Phase 1 + +Note [Unfold compulsory unfoldings in LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the user writes `RULES map coerce = coerce` as a rule, the rule +will only ever match if simpleOptExpr replaces coerce by its unfolding +on the LHS, because that is the core that the rule matching engine +will find. So do that for everything that has a compulsory +unfolding. Also see Note [Desugaring coerce as cast] in GHC.HsToCore. + +However, we don't want to inline 'seq', which happens to also have a +compulsory unfolding, so we only do this unfolding only for things +that are always-active. See Note [User-defined RULES for seq] in MkId. + +Note [Getting the map/coerce RULE to work] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to allow the "map/coerce" RULE to fire: + + {-# RULES "map/coerce" map coerce = coerce #-} + +The naive core produced for this is + + forall a b (dict :: Coercible * a b). + map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict' + + where dict' :: Coercible [a] [b] + dict' = ... + +This matches literal uses of `map coerce` in code, but that's not what we +want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) +too. Some of this is addressed by compulsorily unfolding coerce on the LHS, +yielding + + forall a b (dict :: Coercible * a b). + map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... + +Getting better. But this isn't exactly what gets produced. This is because +Coercible essentially has ~R# as a superclass, and superclasses get eagerly +extracted during solving. So we get this: + + forall a b (dict :: Coercible * a b). + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... + +Unfortunately, this still abstracts over a Coercible dictionary. We really +want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, +which transforms the above to (see also Note [Desugaring coerce as cast] in +Desugar) + + forall a b (co :: a ~R# b). + let dict = MkCoercible @* @a @b co in + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... + +Now, we need simpleOptExpr to fix this up. It does so by taking three +separate actions: + 1. Inline certain non-recursive bindings. The choice whether to inline + is made in simple_bind_pair. Note the rather specific check for + MkCoercible in there. + + 2. Stripping case expressions like the Coercible_SCSel one. + See the `Case` case of simple_opt_expr's `go` function. + + 3. Look for case expressions that unpack something that was + just packed and inline them. This is also done in simple_opt_expr's + `go` function. + +This is all a fair amount of special-purpose hackery, but it's for +a good cause. And it won't hurt other RULES and such that it comes across. + + +************************************************************************ +* * + Join points +* * +************************************************************************ +-} + +-- | Returns Just (bndr,rhs) if the binding is a join point: +-- If it's a JoinId, just return it +-- If it's not yet a JoinId but is always tail-called, +-- make it into a JoinId and return it. +-- In the latter case, eta-expand the RHS if necessary, to make the +-- lambdas explicit, as is required for join points +-- +-- Precondition: the InBndr has been occurrence-analysed, +-- so its OccInfo is valid +joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr) +joinPointBinding_maybe bndr rhs + | not (isId bndr) + = Nothing + + | isJoinId bndr + = Just (bndr, rhs) + + | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr) + , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs + , let str_sig = idStrictness bndr + str_arity = count isId bndrs -- Strictness demands are for Ids only + join_bndr = bndr `asJoinId` join_arity + `setIdStrictness` etaExpandStrictSig str_arity str_sig + = Just (join_bndr, mkLams bndrs body) + + | otherwise + = Nothing + +joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)] +joinPointBindings_maybe bndrs + = mapM (uncurry joinPointBinding_maybe) bndrs + + +{- Note [Strictness and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + let f = \x. if x>200 then e1 else e1 + +and we know that f is strict in x. Then if we subsequently +discover that f is an arity-2 join point, we'll eta-expand it to + + let f = \x y. if x>200 then e1 else e1 + +and now it's only strict if applied to two arguments. So we should +adjust the strictness info. + +A more common case is when + + f = \x. error ".." + +and again its arity increases (#15517) +-} + +{- ********************************************************************* +* * + exprIsConApp_maybe +* * +************************************************************************ + +Note [exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsConApp_maybe is a very important function. There are two principal +uses: + * case e of { .... } + * cls_op e, where cls_op is a class operation + +In both cases you want to know if e is of form (C e1..en) where C is +a data constructor. + +However e might not *look* as if + + +Note [exprIsConApp_maybe on literal strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #9400 and #13317. + +Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core +they are represented as unpackCString# "abc"# by GHC.Core.Make.mkStringExprFS, or +unpackCStringUtf8# when the literal contains multi-byte UTF8 characters. + +For optimizations we want to be able to treat it as a list, so they can be +decomposed when used in a case-statement. exprIsConApp_maybe detects those +calls to unpackCString# and returns: + +Just (':', [Char], ['a', unpackCString# "bc"]). + +We need to be careful about UTF8 strings here. ""# contains a ByteString, so +we must parse it back into a FastString to split off the first character. +That way we can treat unpackCString# and unpackCStringUtf8# in the same way. + +We must also be careful about + lvl = "foo"# + ...(unpackCString# lvl)... +to ensure that we see through the let-binding for 'lvl'. Hence the +(exprIsLiteral_maybe .. arg) in the guard before the call to +dealWithStringLiteral. + +Note [Push coercions in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #13025 I found a case where we had + op (df @t1 @t2) -- op is a ClassOp +where + df = (/\a b. K e1 e2) |> g + +To get this to come out we need to simplify on the fly + ((/\a b. K e1 e2) |> g) @t1 @t2 + +Hence the use of pushCoArgs. + +Note [exprIsConApp_maybe on data constructors with wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: +- some data constructors have wrappers +- these wrappers inline late (see MkId Note [Activation for data constructor wrappers]) +- but we still want case-of-known-constructor to fire early. + +Example: + data T = MkT !Int + $WMkT n = case n of n' -> MkT n' -- Wrapper for MkT + foo x = case $WMkT e of MkT y -> blah + +Here we want the case-of-known-constructor transformation to fire, giving + foo x = case e of x' -> let y = x' in blah + +Here's how exprIsConApp_maybe achieves this: + +0. Start with scrutinee = $WMkT e + +1. Inline $WMkT on-the-fly. That's why data-constructor wrappers are marked + as expandable. (See GHC.Core.Utils.isExpandableApp.) Now we have + scrutinee = (\n. case n of n' -> MkT n') e + +2. Beta-reduce the application, generating a floated 'let'. + See Note [beta-reduction in exprIsConApp_maybe] below. Now we have + scrutinee = case n of n' -> MkT n' + with floats {Let n = e} + +3. Float the "case x of x' ->" binding out. Now we have + scrutinee = MkT n' + with floats {Let n = e; case n of n' ->} + +And now we have a known-constructor MkT that we can return. + +Notice that both (2) and (3) require exprIsConApp_maybe to gather and return +a bunch of floats, both let and case bindings. + +Note [beta-reduction in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is +typically a function. For instance, take the wrapper for MkT in Note +[exprIsConApp_maybe on data constructors with wrappers]: + + $WMkT n = case n of { n' -> T n' } + +If `exprIsConApp_maybe` is trying to analyse `$MkT arg`, upon unfolding of $MkT, +it will see + + (\n -> case n of { n' -> T n' }) arg + +In order to go progress, `exprIsConApp_maybe` must perform a beta-reduction. + +We don't want to blindly substitute `arg` in the body of the function, because +it duplicates work. We can (and, in fact, used to) substitute `arg` in the body, +but only when `arg` is a variable (or something equally work-free). + +But, because of Note [exprIsConApp_maybe on data constructors with wrappers], +'exprIsConApp_maybe' now returns floats. So, instead, we can beta-reduce +_always_: + + (\x -> body) arg + +Is transformed into + + let x = arg in body + +Which, effectively, means emitting a float `let x = arg` and recursively +analysing the body. + +For newtypes, this strategy requires that their wrappers have compulsory unfoldings. +Suppose we have + newtype T a b where + MkT :: a -> T b a -- Note args swapped + +This defines a worker function MkT, a wrapper function $WMkT, and an axT: + $WMkT :: forall a b. a -> T b a + $WMkT = /\b a. \(x:a). MkT a b x -- A real binding + + MkT :: forall a b. a -> T a b + MkT = /\a b. \(x:a). x |> (ax a b) -- A compulsory unfolding + + axiom axT :: a ~R# T a b + +Now we are optimising + case $WMkT (I# 3) |> sym axT of I# y -> ... +we clearly want to simplify this. If $WMkT did not have a compulsory +unfolding, we would end up with + let a = I#3 in case a of I# y -> ... +because in general, we do this on-the-fly beta-reduction + (\x. e) blah --> let x = blah in e +and then float the the let. (Substitution would risk duplicating 'blah'.) + +But if the case-of-known-constructor doesn't actually fire (i.e. +exprIsConApp_maybe does not return Just) then nothing happens, and nothing +will happen the next time either. + +See test T16254, which checks the behavior of newtypes. +-} + +data ConCont = CC [CoreExpr] Coercion + -- Substitution already applied + +-- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument +-- expression is a *saturated* constructor application of the form @let b1 in +-- .. let bp in dc t1..tk x1 .. xn@, where t1..tk are the +-- *universally-quantified* type args of 'dc'. Floats can also be (and most +-- likely are) single-alternative case expressions. Why does +-- 'exprIsConApp_maybe' return floats? We may have to look through lets and +-- cases to detect that we are in the presence of a data constructor wrapper. In +-- this case, we need to return the lets and cases that we traversed. See Note +-- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers +-- are unfolded late, but we really want to trigger case-of-known-constructor as +-- early as possible. See also Note [Activation for data constructor wrappers] +-- in MkId. +-- +-- We also return the incoming InScopeSet, augmented with +-- the binders from any [FloatBind] that we return +exprIsConApp_maybe :: InScopeEnv -> CoreExpr + -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) +exprIsConApp_maybe (in_scope, id_unf) expr + = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr))) + where + go :: Either InScopeSet Subst + -- Left in-scope means "empty substitution" + -- Right subst means "apply this substitution to the CoreExpr" + -- NB: in the call (go subst floats expr cont) + -- the substitution applies to 'expr', but /not/ to 'floats' or 'cont' + -> [FloatBind] -> CoreExpr -> ConCont + -- Notice that the floats here are in reverse order + -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) + go subst floats (Tick t expr) cont + | not (tickishIsCode t) = go subst floats expr cont + + go subst floats (Cast expr co1) (CC args co2) + | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args + -- See Note [Push coercions in exprIsConApp_maybe] + = case m_co1' of + MCo co1' -> go subst floats expr (CC args' (co1' `mkTransCo` co2)) + MRefl -> go subst floats expr (CC args' co2) + + go subst floats (App fun arg) (CC args co) + = go subst floats fun (CC (subst_expr subst arg : args) co) + + go subst floats (Lam bndr body) (CC (arg:args) co) + | exprIsTrivial arg -- Don't duplicate stuff! + = go (extend subst bndr arg) floats body (CC args co) + | otherwise + = let (subst', bndr') = subst_bndr subst bndr + float = FloatLet (NonRec bndr' arg) + in go subst' (float:floats) body (CC args co) + + go subst floats (Let (NonRec bndr rhs) expr) cont + = let rhs' = subst_expr subst rhs + (subst', bndr') = subst_bndr subst bndr + float = FloatLet (NonRec bndr' rhs') + in go subst' (float:floats) expr cont + + go subst floats (Case scrut b _ [(con, vars, expr)]) cont + = let + scrut' = subst_expr subst scrut + (subst', b') = subst_bndr subst b + (subst'', vars') = subst_bndrs subst' vars + float = FloatCase scrut' b' con vars' + in + go subst'' (float:floats) expr cont + + go (Right sub) floats (Var v) cont + = go (Left (substInScope sub)) + floats + (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) + cont + + go (Left in_scope) floats (Var fun) cont@(CC args co) + + | Just con <- isDataConWorkId_maybe fun + , count isValArg args == idArity fun + = succeedWith in_scope floats $ + pushCoDataCon con args co + + -- Look through data constructor wrappers: they inline late (See Note + -- [Activation for data constructor wrappers]) but we want to do + -- case-of-known-constructor optimisation eagerly. + | isDataConWrapId fun + , let rhs = uf_tmpl (realIdUnfolding fun) + = go (Left in_scope) floats rhs cont + + -- Look through dictionary functions; see Note [Unfolding DFuns] + | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding + , bndrs `equalLength` args -- See Note [DFun arity check] + , let subst = mkOpenSubst in_scope (bndrs `zip` args) + = succeedWith in_scope floats $ + pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co + + -- Look through unfoldings, but only arity-zero one; + -- if arity > 0 we are effectively inlining a function call, + -- and that is the business of callSiteInline. + -- In practice, without this test, most of the "hits" were + -- CPR'd workers getting inlined back into their wrappers, + | idArity fun == 0 + , Just rhs <- expandUnfolding_maybe unfolding + , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs) + = go (Left in_scope') floats rhs cont + + -- See Note [exprIsConApp_maybe on literal strings] + | (fun `hasKey` unpackCStringIdKey) || + (fun `hasKey` unpackCStringUtf8IdKey) + , [arg] <- args + , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg + = succeedWith in_scope floats $ + dealWithStringLiteral fun str co + where + unfolding = id_unf fun + + go _ _ _ _ = Nothing + + succeedWith :: InScopeSet -> [FloatBind] + -> Maybe (DataCon, [Type], [CoreExpr]) + -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) + succeedWith in_scope rev_floats x + = do { (con, tys, args) <- x + ; let floats = reverse rev_floats + ; return (in_scope, floats, con, tys, args) } + + ---------------------------- + -- Operations on the (Either InScopeSet GHC.Core.Subst) + -- The Left case is wildly dominant + subst_co (Left {}) co = co + subst_co (Right s) co = GHC.Core.Subst.substCo s co + + subst_expr (Left {}) e = e + subst_expr (Right s) e = substExpr (text "exprIsConApp2") s e + + subst_bndr msubst bndr + = (Right subst', bndr') + where + (subst', bndr') = substBndr subst bndr + subst = case msubst of + Left in_scope -> mkEmptySubst in_scope + Right subst -> subst + + subst_bndrs subst bs = mapAccumL subst_bndr subst bs + + extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) + extend (Right s) v e = Right (extendSubst s v e) + + +-- See Note [exprIsConApp_maybe on literal strings] +dealWithStringLiteral :: Var -> BS.ByteString -> Coercion + -> Maybe (DataCon, [Type], [CoreExpr]) + +-- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS +-- turns those into [] automatically, but just in case something else in GHC +-- generates a string literal directly. +dealWithStringLiteral _ str co + | BS.null str + = pushCoDataCon nilDataCon [Type charTy] co + +dealWithStringLiteral fun str co + = let strFS = mkFastStringByteString str + + char = mkConApp charDataCon [mkCharLit (headFS strFS)] + charTail = bytesFS (tailFS strFS) + + -- In singleton strings, just add [] instead of unpackCstring# ""#. + rest = if BS.null charTail + then mkConApp nilDataCon [Type charTy] + else App (Var fun) + (Lit (LitString charTail)) + + in pushCoDataCon consDataCon [Type charTy, char, rest] co + +{- +Note [Unfolding DFuns] +~~~~~~~~~~~~~~~~~~~~~~ +DFuns look like + + df :: forall a b. (Eq a, Eq b) -> Eq (a,b) + df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) + ($c2 a b d_a d_b) + +So to split it up we just need to apply the ops $c1, $c2 etc +to the very same args as the dfun. It takes a little more work +to compute the type arguments to the dictionary constructor. + +Note [DFun arity check] +~~~~~~~~~~~~~~~~~~~~~~~ +Here we check that the total number of supplied arguments (including +type args) matches what the dfun is expecting. This may be *less* +than the ordinary arity of the dfun: see Note [DFun unfoldings] in GHC.Core +-} + +exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal +-- Same deal as exprIsConApp_maybe, but much simpler +-- Nevertheless we do need to look through unfoldings for +-- Integer and string literals, which are vigorously hoisted to top level +-- and not subsequently inlined +exprIsLiteral_maybe env@(_, id_unf) e + = case e of + Lit l -> Just l + Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? + Var v | Just rhs <- expandUnfolding_maybe (id_unf v) + -> exprIsLiteral_maybe env rhs + _ -> Nothing + +{- +Note [exprIsLambda_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsLambda_maybe will, given an expression `e`, try to turn it into the form +`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through +casts (using the Push rule), and it unfolds function calls if the unfolding +has a greater arity than arguments are present. + +Currently, it is used in GHC.Core.Rules.match, and is required to make +"map coerce = coerce" match. +-} + +exprIsLambda_maybe :: InScopeEnv -> CoreExpr + -> Maybe (Var, CoreExpr,[Tickish Id]) + -- See Note [exprIsLambda_maybe] + +-- The simple case: It is a lambda already +exprIsLambda_maybe _ (Lam x e) + = Just (x, e, []) + +-- Still straightforward: Ticks that we can float out of the way +exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) + | tickishFloatable t + , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e + = Just (x, e, t:ts) + +-- Also possible: A casted lambda. Push the coercion inside +exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) + | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e + -- Only do value lambdas. + -- this implies that x is not in scope in gamma (makes this code simpler) + , not (isTyVar x) && not (isCoVar x) + , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True + , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co + , let res = Just (x',e',ts) + = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) + res + +-- Another attempt: See if we find a partial unfolding +exprIsLambda_maybe (in_scope_set, id_unf) e + | (Var f, as, ts) <- collectArgsTicks tickishFloatable e + , idArity f > count isValArg as + -- Make sure there is hope to get a lambda + , Just rhs <- expandUnfolding_maybe (id_unf f) + -- Optimize, for beta-reduction + , let e' = simpleOptExprWith unsafeGlobalDynFlags (mkEmptySubst in_scope_set) (rhs `mkApps` as) + -- Recurse, because of possible casts + , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' + , let res = Just (x', e'', ts++ts') + = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) + res + +exprIsLambda_maybe _ _e + = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) + Nothing + + +{- ********************************************************************* +* * + 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 co [] = return ([], MCo co) +pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg + ; case m_co1 of + MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args + ; return (arg':args', m_co2) } + MRefl -> return (arg':args, MRefl) } + +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 Simplify.hs +-- 'co' is always Representational +-- If the returned coercion is Nothing, then it would have been reflexive +pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty + ; return (Type ty', m_co') } +pushCoArg co val_arg = do { (arg_co, m_co') <- pushCoValArg co + ; return (val_arg `mkCast` arg_co, 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 co 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) + + | isReflCo co + = Just (ty, MRefl) + + | isForAllTy_ty tyL + = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty ) + Just (ty `mkCastTy` co1, MCo co2) + + | otherwise + = Nothing + where + tyL = coercionLKind co + tyR = coercionRKind co + -- co :: tyL ~ tyR + -- tyL = forall (a1 :: k1). ty1 + -- tyR = forall (a2 :: k2). ty2 + + co1 = mkSymCo (mkNthCo Nominal 0 co) + -- co1 :: k2 ~N k1 + -- Note that NthCo can extract a Nominal equality between the + -- kinds of the types related by a coercion between forall-types. + -- See the NthCo case in GHC.Core.Lint. + + co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1) + -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ] + -- Arg of mkInstCo is always nominal, hence mkNomReflCo + +pushCoValArg :: CoercionR -> Maybe (Coercion, MCoercion) +-- We have (fun |> co) arg +-- Push the coercion through to return +-- (fun (arg |> co_arg)) |> co_res +-- 'co' is always Representational +-- If the second returned Coercion is actually Nothing, then no cast is necessary; +-- the returned coercion would have been reflexive. +pushCoValArg 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) + + | isReflCo co + = Just (mkRepReflCo arg, MRefl) + + | isFunTy tyL + , (co1, co2) <- decomposeFunCo Representational co + -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) + -- then co1 :: tyL1 ~ tyR1 + -- co2 :: tyL2 ~ tyR2 + = ASSERT2( isFunTy tyR, ppr co $$ ppr arg ) + Just (mkSymCo co1, MCo co2) + + | otherwise + = Nothing + where + arg = funArgTy tyR + Pair tyL tyR = coercionKind co + +pushCoercionIntoLambda + :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) +-- This implements the Push rule from the paper on coercions +-- (\x. e) |> co +-- ===> +-- (\x'. e |> co') +pushCoercionIntoLambda in_scope x e co + | ASSERT(not (isTyVar x) && not (isCoVar x)) True + , Pair s1s2 t1t2 <- coercionKind co + , Just (_s1,_s2) <- splitFunTy_maybe s1s2 + , Just (t1,_t2) <- splitFunTy_maybe t1t2 + = let (co1, co2) = decomposeFunCo Representational co + -- Should we optimize the coercions here? + -- Otherwise they might not match too well + x' = x `setIdType` t1 + in_scope' = in_scope `extendInScopeSet` x' + subst = extendIdSubst (mkEmptySubst in_scope') + x + (mkCast (Var x') co1) + in Just (x', substExpr (text "pushCoercionIntoLambda") subst e `mkCast` co2) + | otherwise + = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) + Nothing + +pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion + -> 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 dc dc_args co + | isReflCo co || from_ty `eqType` to_ty -- try cheap test first + , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args + = Just (dc, map exprToType univ_ty_args, rest_args) + + | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty + , to_tc == dataConTyCon 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 = tyConArity to_tc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tcvars = dataConExTyCoVars dc + arg_tys = dataConRepArgTys dc + + non_univ_args = dropList dc_univ_tyvars dc_args + (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args + + -- Make the "Psi" from the paper + omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc) + (psi_subst, to_ex_arg_tys) + = liftCoSubstWithEx Representational + dc_univ_tyvars + omegas + dc_ex_tcvars + (map exprToType ex_args) + + -- Cast the value arguments (which include dictionaries) + new_val_args = zipWith cast_arg arg_tys val_args + cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) + + to_ex_args = map Type to_ex_arg_tys + + dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars, + ppr arg_tys, ppr dc_args, + ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ] + in + ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc ) + ASSERT2( equalLength val_args arg_tys, dump_doc ) + Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) + + | otherwise + = Nothing + + where + Pair from_ty to_ty = coercionKind co + +collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) +-- Collect lambda binders, pushing coercions inside if possible +-- E.g. (\x.e) |> g g :: <Int> -> blah +-- = (\x. e |> Nth 1 g) +-- +-- That is, +-- +-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g) +collectBindersPushingCo e + = go [] e + where + -- Peel off lambdas until we hit a cast. + go :: [Var] -> CoreExpr -> ([Var], CoreExpr) + -- The accumulator is in reverse order + go bs (Lam b e) = go (b:bs) e + go bs (Cast e co) = go_c bs e co + go bs e = (reverse bs, 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 bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) + go_c bs (Lam b e) co = go_lam bs b e co + go_c bs e co = (reverse bs, mkCast e 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 bs b e co + | isTyVar b + , let Pair tyL tyR = coercionKind co + , ASSERT( isForAllTy_ty tyL ) + isForAllTy_ty tyR + , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] + = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) + + | isCoVar b + , let Pair tyL tyR = coercionKind co + , ASSERT( isForAllTy_co tyL ) + isForAllTy_co tyR + , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] + , let cov = mkCoVarCo b + = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov))) + + | isId b + , let Pair tyL tyR = coercionKind co + , ASSERT( isFunTy tyL) isFunTy tyR + , (co_arg, co_res) <- decomposeFunCo Representational co + , isReflCo co_arg -- See Note [collectBindersPushingCo] + = go_c (b:bs) e co_res + + | otherwise = (reverse bs, mkCast (Lam b e) co) + +{- + +Note [collectBindersPushingCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We just look for coercions of form + <type> -> blah +(and similarly for foralls) to keep this function simple. We could do +more elaborate stuff, but it'd involve substitution etc. + +-} diff --git a/compiler/GHC/Core/Stats.hs b/compiler/GHC/Core/Stats.hs new file mode 100644 index 0000000000..fe288f5348 --- /dev/null +++ b/compiler/GHC/Core/Stats.hs @@ -0,0 +1,137 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-2015 +-} + +-- | Functions to computing the statistics reflective of the "size" +-- of a Core expression +module GHC.Core.Stats ( + -- * Expression and bindings size + coreBindsSize, exprSize, + CoreStats(..), coreBindsStats, exprStats, + ) where + +import GhcPrelude + +import BasicTypes +import GHC.Core +import Outputable +import Coercion +import Var +import Type (Type, typeSize) +import Id (isJoinId) + +data CoreStats = CS { cs_tm :: !Int -- Terms + , cs_ty :: !Int -- Types + , cs_co :: !Int -- Coercions + , cs_vb :: !Int -- Local value bindings + , cs_jb :: !Int } -- Local join bindings + + +instance Outputable CoreStats where + ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3, cs_vb = i4, cs_jb = i5 }) + = braces (sep [text "terms:" <+> intWithCommas i1 <> comma, + text "types:" <+> intWithCommas i2 <> comma, + text "coercions:" <+> intWithCommas i3 <> comma, + text "joins:" <+> intWithCommas i5 <> char '/' <> + intWithCommas (i4 + i5) ]) + +plusCS :: CoreStats -> CoreStats -> CoreStats +plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1, cs_vb = v1, cs_jb = j1 }) + (CS { cs_tm = p2, cs_ty = q2, cs_co = r2, cs_vb = v2, cs_jb = j2 }) + = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2, cs_vb = v1+v2 + , cs_jb = j1+j2 } + +zeroCS, oneTM :: CoreStats +zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0, cs_vb = 0, cs_jb = 0 } +oneTM = zeroCS { cs_tm = 1 } + +sumCS :: (a -> CoreStats) -> [a] -> CoreStats +sumCS f = foldl' (\s a -> plusCS s (f a)) zeroCS + +coreBindsStats :: [CoreBind] -> CoreStats +coreBindsStats = sumCS (bindStats TopLevel) + +bindStats :: TopLevelFlag -> CoreBind -> CoreStats +bindStats top_lvl (NonRec v r) = bindingStats top_lvl v r +bindStats top_lvl (Rec prs) = sumCS (\(v,r) -> bindingStats top_lvl v r) prs + +bindingStats :: TopLevelFlag -> Var -> CoreExpr -> CoreStats +bindingStats top_lvl v r = letBndrStats top_lvl v `plusCS` exprStats r + +bndrStats :: Var -> CoreStats +bndrStats v = oneTM `plusCS` tyStats (varType v) + +letBndrStats :: TopLevelFlag -> Var -> CoreStats +letBndrStats top_lvl v + | isTyVar v || isTopLevel top_lvl = bndrStats v + | isJoinId v = oneTM { cs_jb = 1 } `plusCS` ty_stats + | otherwise = oneTM { cs_vb = 1 } `plusCS` ty_stats + where + ty_stats = tyStats (varType v) + +exprStats :: CoreExpr -> CoreStats +exprStats (Var {}) = oneTM +exprStats (Lit {}) = oneTM +exprStats (Type t) = tyStats t +exprStats (Coercion c) = coStats c +exprStats (App f a) = exprStats f `plusCS` exprStats a +exprStats (Lam b e) = bndrStats b `plusCS` exprStats e +exprStats (Let b e) = bindStats NotTopLevel b `plusCS` exprStats e +exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b + `plusCS` sumCS altStats as +exprStats (Cast e co) = coStats co `plusCS` exprStats e +exprStats (Tick _ e) = exprStats e + +altStats :: CoreAlt -> CoreStats +altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r + +altBndrStats :: [Var] -> CoreStats +-- Charge one for the alternative, not for each binder +altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs + +tyStats :: Type -> CoreStats +tyStats ty = zeroCS { cs_ty = typeSize ty } + +coStats :: Coercion -> CoreStats +coStats co = zeroCS { cs_co = coercionSize co } + +coreBindsSize :: [CoreBind] -> Int +-- We use coreBindStats for user printout +-- but this one is a quick and dirty basis for +-- the simplifier's tick limit +coreBindsSize bs = sum (map bindSize bs) + +exprSize :: CoreExpr -> Int +-- ^ A measure of the size of the expressions, strictly greater than 0 +-- Counts *leaves*, not internal nodes. Types and coercions are not counted. +exprSize (Var _) = 1 +exprSize (Lit _) = 1 +exprSize (App f a) = exprSize f + exprSize a +exprSize (Lam b e) = bndrSize b + exprSize e +exprSize (Let b e) = bindSize b + exprSize e +exprSize (Case e b _ as) = exprSize e + bndrSize b + 1 + sum (map altSize as) +exprSize (Cast e _) = 1 + exprSize e +exprSize (Tick n e) = tickSize n + exprSize e +exprSize (Type _) = 1 +exprSize (Coercion _) = 1 + +tickSize :: Tickish Id -> Int +tickSize (ProfNote _ _ _) = 1 +tickSize _ = 1 + +bndrSize :: Var -> Int +bndrSize _ = 1 + +bndrsSize :: [Var] -> Int +bndrsSize = sum . map bndrSize + +bindSize :: CoreBind -> Int +bindSize (NonRec b e) = bndrSize b + exprSize e +bindSize (Rec prs) = sum (map pairSize prs) + +pairSize :: (Var, CoreExpr) -> Int +pairSize (b,e) = bndrSize b + exprSize e + +altSize :: CoreAlt -> Int +altSize (_,bs,e) = bndrsSize bs + exprSize e diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs new file mode 100644 index 0000000000..e61088a277 --- /dev/null +++ b/compiler/GHC/Core/Subst.hs @@ -0,0 +1,758 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utility functions on @Core@ syntax +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +module GHC.Core.Subst ( + -- * Main data types + Subst(..), -- Implementation exported for supercompiler's Renaming.hs only + TvSubstEnv, IdSubstEnv, InScopeSet, + + -- ** Substituting into expressions and related types + deShadowBinds, substSpec, substRulesForImportedIds, + substTy, substCo, substExpr, substExprSC, substBind, substBindSC, + substUnfolding, substUnfoldingSC, + lookupIdSubst, lookupTCvSubst, substIdOcc, + substTickish, substDVarSet, substIdInfo, + + -- ** Operations on substitutions + emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, + extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, + extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, + addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, + isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, + delBndr, delBndrs, + + -- ** Substituting and cloning binders + substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, + cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + + ) where + +#include "HsVersions.h" + + +import GhcPrelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Seq +import GHC.Core.Utils +import qualified Type +import qualified Coercion + + -- We are defining local versions +import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import Coercion hiding ( substCo, substCoVarBndr ) + +import PrelNames +import VarSet +import VarEnv +import Id +import Name ( Name ) +import Var +import IdInfo +import UniqSupply +import Maybes +import Util +import Outputable +import Data.List + + + +{- +************************************************************************ +* * +\subsection{Substitutions} +* * +************************************************************************ +-} + +-- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar' +-- substitutions. +-- +-- Some invariants apply to how you use the substitution: +-- +-- 1. Note [The substitution invariant] in TyCoSubst +-- +-- 2. Note [Substitutions apply only once] in TyCoSubst +data Subst + = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ + -- applying the substitution + IdSubstEnv -- Substitution from NcIds to CoreExprs + TvSubstEnv -- Substitution from TyVars to Types + CvSubstEnv -- Substitution from CoVars to Coercions + + -- INVARIANT 1: See TyCoSubst Note [The substitution invariant] + -- This is what lets us deal with name capture properly + -- It's a hard invariant to check... + -- + -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with + -- Types.TvSubstEnv + -- + -- INVARIANT 3: See Note [Extending the Subst] + +{- +Note [Extending the Subst] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a core Subst, which binds Ids as well, we make a different choice for Ids +than we do for TyVars. + +For TyVars, see Note [Extending the TCvSubst] in TyCoSubst. + +For Ids, we have a different invariant + The IdSubstEnv is extended *only* when the Unique on an Id changes + Otherwise, we just extend the InScopeSet + +In consequence: + +* If all subst envs are empty, substExpr would be a + no-op, so substExprSC ("short cut") does nothing. + + However, substExpr still goes ahead and substitutes. Reason: we may + want to replace existing Ids with new ones from the in-scope set, to + avoid space leaks. + +* In substIdBndr, we extend the IdSubstEnv only when the unique changes + +* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty, + substExpr does nothing (Note that the above rule for substIdBndr + maintains this property. If the incoming envts are both empty, then + substituting the type and IdInfo can't change anything.) + +* In lookupIdSubst, we *must* look up the Id in the in-scope set, because + it may contain non-trivial changes. Example: + (/\a. \x:a. ...x...) Int + We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change + so we only extend the in-scope set. Then we must look up in the in-scope + set when we find the occurrence of x. + +* The requirement to look up the Id in the in-scope set means that we + must NOT take no-op short cut when the IdSubst is empty. + We must still look up every Id in the in-scope set. + +* (However, we don't need to do so for expressions found in the IdSubst + itself, whose range is assumed to be correct wrt the in-scope set.) + +Why do we make a different choice for the IdSubstEnv than the +TvSubstEnv and CvSubstEnv? + +* For Ids, we change the IdInfo all the time (e.g. deleting the + unfolding), and adding it back later, so using the TyVar convention + would entail extending the substitution almost all the time + +* The simplifier wants to look up in the in-scope set anyway, in case it + can see a better unfolding from an enclosing case expression + +* For TyVars, only coercion variables can possibly change, and they are + easy to spot +-} + +-- | An environment for substituting for 'Id's +type IdSubstEnv = IdEnv CoreExpr -- Domain is NcIds, i.e. not coercions + +---------------------------- +isEmptySubst :: Subst -> Bool +isEmptySubst (Subst _ id_env tv_env cv_env) + = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env + +emptySubst :: Subst +emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv + +mkEmptySubst :: InScopeSet -> Subst +mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv + +mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst +mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs + +-- | Find the in-scope set: see TyCoSubst Note [The substitution invariant] +substInScope :: Subst -> InScopeSet +substInScope (Subst in_scope _ _ _) = in_scope + +-- | Remove all substitutions for 'Id's and 'Var's that might have been built up +-- while preserving the in-scope set +zapSubstEnv :: Subst -> Subst +zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv + +-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is +-- such that TyCoSubst Note [The substitution invariant] +-- holds after extending the substitution like this +extendIdSubst :: Subst -> Id -> CoreExpr -> Subst +-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set +extendIdSubst (Subst in_scope ids tvs cvs) v r + = ASSERT2( isNonCoVarId v, ppr v $$ ppr r ) + Subst in_scope (extendVarEnv ids v r) tvs cvs + +-- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' +extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst +extendIdSubstList (Subst in_scope ids tvs cvs) prs + = ASSERT( all (isNonCoVarId . fst) prs ) + Subst in_scope (extendVarEnvList ids prs) tvs cvs + +-- | Add a substitution for a 'TyVar' to the 'Subst' +-- The 'TyVar' *must* be a real TyVar, and not a CoVar +-- You must ensure that the in-scope set is such that +-- TyCoSubst Note [The substitution invariant] holds +-- after extending the substitution like this. +extendTvSubst :: Subst -> TyVar -> Type -> Subst +extendTvSubst (Subst in_scope ids tvs cvs) tv ty + = ASSERT( isTyVar tv ) + Subst in_scope ids (extendVarEnv tvs tv ty) cvs + +-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' +extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst +extendTvSubstList subst vrs + = foldl' extend subst vrs + where + extend subst (v, r) = extendTvSubst subst v r + +-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': +-- you must ensure that the in-scope set satisfies +-- TyCoSubst Note [The substitution invariant] +-- after extending the substitution like this +extendCvSubst :: Subst -> CoVar -> Coercion -> Subst +extendCvSubst (Subst in_scope ids tvs cvs) v r + = ASSERT( isCoVar v ) + Subst in_scope ids tvs (extendVarEnv cvs v r) + +-- | Add a substitution appropriate to the thing being substituted +-- (whether an expression, type, or coercion). See also +-- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' +extendSubst :: Subst -> Var -> CoreArg -> Subst +extendSubst subst var arg + = case arg of + Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty + Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co + _ -> ASSERT( isId var ) extendIdSubst subst var arg + +extendSubstWithVar :: Subst -> Var -> Var -> Subst +extendSubstWithVar subst v1 v2 + | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2) + | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2) + | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2) + +-- | Add a substitution as appropriate to each of the terms being +-- substituted (whether expressions, types, or coercions). See also +-- 'extendSubst'. +extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst +extendSubstList subst [] = subst +extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs + +-- | Find the substitution for an 'Id' in the 'Subst' +lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr +lookupIdSubst doc (Subst in_scope ids _ _) v + | not (isLocalId v) = Var v + | Just e <- lookupVarEnv ids v = e + | Just v' <- lookupInScope in_scope v = Var v' + -- Vital! See Note [Extending the Subst] + | otherwise = WARN( True, text "GHC.Core.Subst.lookupIdSubst" <+> doc <+> ppr v + $$ ppr in_scope) + Var v + +-- | Find the substitution for a 'TyVar' in the 'Subst' +lookupTCvSubst :: Subst -> TyVar -> Type +lookupTCvSubst (Subst _ _ tvs cvs) v + | isTyVar v + = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v + | otherwise + = mkCoercionTy $ lookupVarEnv cvs v `orElse` mkCoVarCo v + +delBndr :: Subst -> Var -> Subst +delBndr (Subst in_scope ids tvs cvs) v + | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) + | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs + | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs + +delBndrs :: Subst -> [Var] -> Subst +delBndrs (Subst in_scope ids tvs cvs) vs + = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs) + -- Easiest thing is just delete all from all! + +-- | Simultaneously substitute for a bunch of variables +-- No left-right shadowing +-- ie the substitution for (\x \y. e) a1 a2 +-- so neither x nor y scope over a1 a2 +mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst +mkOpenSubst in_scope pairs = Subst in_scope + (mkVarEnv [(id,e) | (id, e) <- pairs, isId id]) + (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) + (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) + +------------------------------ +isInScope :: Var -> Subst -> Bool +isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope + +-- | Add the 'Var' to the in-scope set, but do not remove +-- any existing substitutions for it +addInScopeSet :: Subst -> VarSet -> Subst +addInScopeSet (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs + +-- | Add the 'Var' to the in-scope set: as a side effect, +-- and remove any existing substitutions for it +extendInScope :: Subst -> Var -> Subst +extendInScope (Subst in_scope ids tvs cvs) v + = Subst (in_scope `extendInScopeSet` v) + (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v) + +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendInScopeList :: Subst -> [Var] -> Subst +extendInScopeList (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs) + +-- | Optimized version of 'extendInScopeList' that can be used if you are certain +-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's +extendInScopeIds :: Subst -> [Id] -> Subst +extendInScopeIds (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + (ids `delVarEnvList` vs) tvs cvs + +setInScope :: Subst -> InScopeSet -> Subst +setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs + +-- Pretty printing, for debugging only + +instance Outputable Subst where + ppr (Subst in_scope ids tvs cvs) + = text "<InScope =" <+> in_scope_doc + $$ text " IdSubst =" <+> ppr ids + $$ text " TvSubst =" <+> ppr tvs + $$ text " CvSubst =" <+> ppr cvs + <> char '>' + where + in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) + +{- +************************************************************************ +* * + Substituting expressions +* * +************************************************************************ +-} + +-- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only +-- apply the substitution /once/: +-- See Note [Substitutions apply only once] in TyCoSubst +-- +-- Do *not* attempt to short-cut in the case of an empty substitution! +-- See Note [Extending the Subst] +substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr +substExprSC doc subst orig_expr + | isEmptySubst subst = orig_expr + | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $ + subst_expr doc subst orig_expr + +substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr +substExpr doc subst orig_expr = subst_expr doc subst orig_expr + +subst_expr :: SDoc -> Subst -> CoreExpr -> CoreExpr +subst_expr doc subst expr + = go expr + where + go (Var v) = lookupIdSubst (doc $$ text "subst_expr") subst v + go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (substCo subst co) + go (Lit lit) = Lit lit + go (App fun arg) = App (go fun) (go arg) + go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) + go (Cast e co) = Cast (go e) (substCo subst co) + -- Do not optimise even identity coercions + -- Reason: substitution applies to the LHS of RULES, and + -- if you "optimise" an identity coercion, you may + -- lose a binder. We optimise the LHS of rules at + -- construction time + + go (Lam bndr body) = Lam bndr' (subst_expr doc subst' body) + where + (subst', bndr') = substBndr subst bndr + + go (Let bind body) = Let bind' (subst_expr doc subst' body) + where + (subst', bind') = substBind subst bind + + go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts) + where + (subst', bndr') = substBndr subst bndr + + go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr doc subst' rhs) + where + (subst', bndrs') = substBndrs subst bndrs + +-- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst' +-- that should be used by subsequent substitutions. +substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind) + +substBindSC subst bind -- Short-cut if the substitution is empty + | not (isEmptySubst subst) + = substBind subst bind + | otherwise + = case bind of + NonRec bndr rhs -> (subst', NonRec bndr' rhs) + where + (subst', bndr') = substBndr subst bndr + Rec pairs -> (subst', Rec (bndrs' `zip` rhss')) + where + (bndrs, rhss) = unzip pairs + (subst', bndrs') = substRecBndrs subst bndrs + rhss' | isEmptySubst subst' + = rhss + | otherwise + = map (subst_expr (text "substBindSC") subst') rhss + +substBind subst (NonRec bndr rhs) + = (subst', NonRec bndr' (subst_expr (text "substBind") subst rhs)) + where + (subst', bndr') = substBndr subst bndr + +substBind subst (Rec pairs) + = (subst', Rec (bndrs' `zip` rhss')) + where + (bndrs, rhss) = unzip pairs + (subst', bndrs') = substRecBndrs subst bndrs + rhss' = map (subst_expr (text "substBind") subst') rhss + +-- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply +-- by running over the bindings with an empty substitution, because substitution +-- returns a result that has no-shadowing guaranteed. +-- +-- (Actually, within a single /type/ there might still be shadowing, because +-- 'substTy' is a no-op for the empty substitution, but that's probably OK.) +-- +-- [Aug 09] This function is not used in GHC at the moment, but seems so +-- short and simple that I'm going to leave it here +deShadowBinds :: CoreProgram -> CoreProgram +deShadowBinds binds = snd (mapAccumL substBind emptySubst binds) + +{- +************************************************************************ +* * + Substituting binders +* * +************************************************************************ + +Remember that substBndr and friends are used when doing expression +substitution only. Their only business is substitution, so they +preserve all IdInfo (suitably substituted). For example, we *want* to +preserve occ info in rules. +-} + +-- | Substitutes a 'Var' for another one according to the 'Subst' given, returning +-- the result and an updated 'Subst' that should be used by subsequent substitutions. +-- 'IdInfo' is preserved by this process, although it is substituted into appropriately. +substBndr :: Subst -> Var -> (Subst, Var) +substBndr subst bndr + | isTyVar bndr = substTyVarBndr subst bndr + | isCoVar bndr = substCoVarBndr subst bndr + | otherwise = substIdBndr (text "var-bndr") subst subst bndr + +-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right +substBndrs :: Subst -> [Var] -> (Subst, [Var]) +substBndrs subst bndrs = mapAccumL substBndr subst bndrs + +-- | Substitute in a mutually recursive group of 'Id's +substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) +substRecBndrs subst bndrs + = (new_subst, new_bndrs) + where -- Here's the reason we need to pass rec_subst to subst_id + (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs + +substIdBndr :: SDoc + -> Subst -- ^ Substitution to use for the IdInfo + -> Subst -> Id -- ^ Substitution and Id to transform + -> (Subst, Id) -- ^ Transformed pair + -- NB: unfolding may be zapped + +substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id + = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $ + (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id) + where + id1 = uniqAway in_scope old_id -- id1 is cloned if necessary + id2 | no_type_change = id1 + | otherwise = setIdType id1 (substTy subst old_ty) + + old_ty = idType old_id + no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || + noFreeVarsOfType old_ty + + -- new_id has the right IdInfo + -- The lazy-set is because we're in a loop here, with + -- rec_subst, when dealing with a mutually-recursive group + new_id = maybeModifyIdInfo mb_new_info id2 + mb_new_info = substIdInfo rec_subst id2 (idInfo id2) + -- NB: unfolding info may be zapped + + -- Extend the substitution if the unique has changed + -- See the notes with substTyVarBndr for the delVarEnv + new_env | no_change = delVarEnv env old_id + | otherwise = extendVarEnv env old_id (Var new_id) + + no_change = id1 == old_id + -- See Note [Extending the Subst] + -- it's /not/ necessary to check mb_new_info and no_type_change + +{- +Now a variant that unconditionally allocates a new unique. +It also unconditionally zaps the OccInfo. +-} + +-- | Very similar to 'substBndr', but it always allocates a new 'Unique' for +-- each variable in its output. It substitutes the IdInfo though. +cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) +cloneIdBndr subst us old_id + = clone_id subst subst (old_id, uniqFromSupply us) + +-- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final +-- substitution from left to right +cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneIdBndrs subst us ids + = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) + +cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) +-- Works for all kinds of variables (typically case binders) +-- not just Ids +cloneBndrs subst us vs + = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us) + +cloneBndr :: Subst -> Unique -> Var -> (Subst, Var) +cloneBndr subst uniq v + | isTyVar v = cloneTyVarBndr subst v uniq + | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too + +-- | Clone a mutually recursive group of 'Id's +cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneRecIdBndrs subst us ids + = (subst', ids') + where + (subst', ids') = mapAccumL (clone_id subst') subst + (ids `zip` uniqsFromSupply us) + +-- Just like substIdBndr, except that it always makes a new unique +-- It is given the unique to use +clone_id :: Subst -- Substitution for the IdInfo + -> Subst -> (Id, Unique) -- Substitution and Id to transform + -> (Subst, Id) -- Transformed pair + +clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) + = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id) + where + id1 = setVarUnique old_id uniq + id2 = substIdType subst id1 + new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2 + (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id)) + | otherwise = (extendVarEnv idvs old_id (Var new_id), cvs) + +{- +************************************************************************ +* * + Types and Coercions +* * +************************************************************************ + +For types and coercions we just call the corresponding functions in +Type and Coercion, but we have to repackage the substitution, from a +Subst to a TCvSubst. +-} + +substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) +substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv + = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of + (TCvSubst in_scope' tv_env' cv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env', tv') + +cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) +cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq + = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of + (TCvSubst in_scope' tv_env' cv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env', tv') + +substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar) +substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv + = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of + (TCvSubst in_scope' tv_env' cv_env', cv') + -> (Subst in_scope' id_env tv_env' cv_env', cv') + +-- | See 'Type.substTy' +substTy :: Subst -> Type -> Type +substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty + +getTCvSubst :: Subst -> TCvSubst +getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv + +-- | See 'Coercion.substCo' +substCo :: HasCallStack => Subst -> Coercion -> Coercion +substCo subst co = Coercion.substCo (getTCvSubst subst) co + +{- +************************************************************************ +* * +\section{IdInfo substitution} +* * +************************************************************************ +-} + +substIdType :: Subst -> Id -> Id +substIdType subst@(Subst _ _ tv_env cv_env) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || noFreeVarsOfType old_ty = id + | otherwise = setIdType id (substTy subst old_ty) + -- The tyCoVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + old_ty = idType id + +------------------ +-- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. +substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo +substIdInfo subst new_id info + | nothing_to_do = Nothing + | otherwise = Just (info `setRuleInfo` substSpec subst new_id old_rules + `setUnfoldingInfo` substUnfolding subst old_unf) + where + old_rules = ruleInfo info + old_unf = unfoldingInfo info + nothing_to_do = isEmptyRuleInfo old_rules && not (isFragileUnfolding old_unf) + +------------------ +-- | Substitutes for the 'Id's within an unfolding +substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding + -- Seq'ing on the returned Unfolding is enough to cause + -- all the substitutions to happen completely + +substUnfoldingSC subst unf -- Short-cut version + | isEmptySubst subst = unf + | otherwise = substUnfolding subst unf + +substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = df { df_bndrs = bndrs', df_args = args' } + where + (subst',bndrs') = substBndrs subst bndrs + args' = map (substExpr (text "subst-unf:dfun") subst') args + +substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) + -- Retain an InlineRule! + | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work + = NoUnfolding + | otherwise -- But keep a stable one! + = seqExpr new_tmpl `seq` + unf { uf_tmpl = new_tmpl } + where + new_tmpl = substExpr (text "subst-unf") subst tmpl + +substUnfolding _ unf = unf -- NoUnfolding, OtherCon + +------------------ +substIdOcc :: Subst -> Id -> Id +-- These Ids should not be substituted to non-Ids +substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of + Var v' -> v' + other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst]) + +------------------ +-- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id' +substSpec :: Subst -> Id -> RuleInfo -> RuleInfo +substSpec subst new_id (RuleInfo rules rhs_fvs) + = seqRuleInfo new_spec `seq` new_spec + where + subst_ru_fn = const (idName new_id) + new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules) + (substDVarSet subst rhs_fvs) + +------------------ +substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] +substRulesForImportedIds subst rules + = map (substRule subst not_needed) rules + where + not_needed name = pprPanic "substRulesForImportedIds" (ppr name) + +------------------ +substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule + +-- The subst_ru_fn argument is applied to substitute the ru_fn field +-- of the rule: +-- - Rules for *imported* Ids never change ru_fn +-- - Rules for *local* Ids are in the IdInfo for that Id, +-- and the ru_fn field is simply replaced by the new name +-- of the Id +substRule _ _ rule@(BuiltinRule {}) = rule +substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs + , ru_local = is_local }) + = rule { ru_bndrs = bndrs' + , ru_fn = if is_local + then subst_ru_fn fn_name + else fn_name + , ru_args = map (substExpr doc subst') args + , ru_rhs = substExpr (text "foo") subst' rhs } + -- Do NOT optimise the RHS (previously we did simplOptExpr here) + -- See Note [Substitute lazily] + where + doc = text "subst-rule" <+> ppr fn_name + (subst', bndrs') = substBndrs subst bndrs + +------------------ +substDVarSet :: Subst -> DVarSet -> DVarSet +substDVarSet subst fvs + = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs + where + subst_fv subst fv acc + | isId fv = expr_fvs (lookupIdSubst (text "substDVarSet") subst fv) isLocalVar emptyVarSet $! acc + | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc + +------------------ +substTickish :: Subst -> Tickish Id -> Tickish Id +substTickish subst (Breakpoint n ids) + = Breakpoint n (map do_one ids) + where + do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst +substTickish _subst other = other + +{- Note [Substitute lazily] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions that substitute over IdInfo must be pretty lazy, because +they are knot-tied by substRecBndrs. + +One case in point was #10627 in which a rule for a function 'f' +referred to 'f' (at a different type) on the RHS. But instead of just +substituting in the rhs of the rule, we were calling simpleOptExpr, which +looked at the idInfo for 'f'; result <<loop>>. + +In any case we don't need to optimise the RHS of rules, or unfoldings, +because the simplifier will do that. + + +Note [substTickish] +~~~~~~~~~~~~~~~~~~~~~~ +A Breakpoint contains a list of Ids. What happens if we ever want to +substitute an expression for one of these Ids? + +First, we ensure that we only ever substitute trivial expressions for +these Ids, by marking them as NoOccInfo in the occurrence analyser. +Then, when substituting for the Id, we unwrap any type applications +and abstractions to get back to an Id, with getIdFromTrivialExpr. + +Second, we have to ensure that we never try to substitute a literal +for an Id in a breakpoint. We ensure this by never storing an Id with +an unlifted type in a Breakpoint - see GHC.HsToCore.Coverage.mkTickish. +Breakpoints can't handle free variables with unlifted types anyway. +-} + +{- +Note [Worker inlining] +~~~~~~~~~~~~~~~~~~~~~~ +A worker can get substituted away entirely. + - it might be trivial + - it might simply be very small +We do not treat an InlWrapper as an 'occurrence' in the occurrence +analyser, so it's possible that the worker is not even in scope any more. + +In all all these cases we simply drop the special case, returning to +InlVanilla. The WARN is just so I can see if it happens a lot. +-} + diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs new file mode 100644 index 0000000000..a895df36c0 --- /dev/null +++ b/compiler/GHC/Core/Unfold.hs @@ -0,0 +1,1642 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +Core-syntax unfoldings + +Unfoldings (which can travel across module boundaries) are in Core +syntax (namely @CoreExpr@s). + +The type @Unfolding@ sits ``above'' simply-Core-expressions +unfoldings, capturing ``higher-level'' things we know about a binding, +usually things that the simplifier found out (e.g., ``it's a +literal''). In the corner of a @CoreUnfolding@ unfolding, you will +find, unsurprisingly, a Core expression. +-} + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Core.Unfold ( + Unfolding, UnfoldingGuidance, -- Abstract types + + noUnfolding, mkImplicitUnfolding, + mkUnfolding, mkCoreUnfolding, + mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding, + mkInlineUnfolding, mkInlineUnfoldingWithArity, + mkInlinableUnfolding, mkWwInlineRule, + mkCompulsoryUnfolding, mkDFunUnfolding, + specUnfolding, + + ArgSummary(..), + + couldBeSmallEnoughToInline, inlineBoringOk, + certainlyWillInline, smallEnoughToInline, + + callSiteInline, CallCtxt(..), + + -- Reexport from GHC.Core.Subst (it only live there so it can be used + -- by the Very Simple Optimiser) + exprIsConApp_maybe, exprIsLiteral_maybe + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Driver.Session +import GHC.Core +import OccurAnal ( occurAnalyseExpr_NoBinderSwap ) +import GHC.Core.SimpleOpt +import GHC.Core.Arity ( manifestArity ) +import GHC.Core.Utils +import Id +import Demand ( isBottomingSig ) +import DataCon +import Literal +import PrimOp +import IdInfo +import BasicTypes ( Arity, InlineSpec(..), inlinePragmaSpec ) +import Type +import PrelNames +import TysPrim ( realWorldStatePrimTy ) +import Bag +import Util +import Outputable +import ForeignCall +import Name +import ErrUtils + +import qualified Data.ByteString as BS +import Data.List + +{- +************************************************************************ +* * +\subsection{Making unfoldings} +* * +************************************************************************ +-} + +mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding +mkTopUnfolding dflags is_bottoming rhs + = mkUnfolding dflags InlineRhs True is_bottoming rhs + +mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding +-- For implicit Ids, do a tiny bit of optimising first +mkImplicitUnfolding dflags expr + = mkTopUnfolding dflags False (simpleOptExpr dflags expr) + +-- Note [Top-level flag on inline rules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Slight hack: note that mk_inline_rules conservatively sets the +-- top-level flag to True. It gets set more accurately by the simplifier +-- Simplify.simplUnfolding. + +mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding +mkSimpleUnfolding dflags rhs + = mkUnfolding dflags InlineRhs False False rhs + +mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding +mkDFunUnfolding bndrs con ops + = DFunUnfolding { df_bndrs = bndrs + , df_con = con + , df_args = map occurAnalyseExpr_NoBinderSwap ops } + -- See Note [Occurrence analysis of unfoldings] + +mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding +mkWwInlineRule dflags expr arity + = mkCoreUnfolding InlineStable True + (simpleOptExpr dflags expr) + (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boringCxtNotOk }) + +mkCompulsoryUnfolding :: CoreExpr -> Unfolding +mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded + = mkCoreUnfolding InlineCompulsory True + (simpleOptExpr unsafeGlobalDynFlags expr) + (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter + , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) + +mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding +-- See Note [Worker-wrapper for INLINABLE functions] in WorkWrap +mkWorkerUnfolding dflags work_fn + (CoreUnfolding { uf_src = src, uf_tmpl = tmpl + , uf_is_top = top_lvl }) + | isStableSource src + = mkCoreUnfolding src top_lvl new_tmpl guidance + where + new_tmpl = simpleOptExpr dflags (work_fn tmpl) + guidance = calcUnfoldingGuidance dflags False new_tmpl + +mkWorkerUnfolding _ _ _ = noUnfolding + +-- | Make an unfolding that may be used unsaturated +-- (ug_unsat_ok = unSaturatedOk) and that is reported as having its +-- manifest arity (the number of outer lambdas applications will +-- resolve before doing any work). +mkInlineUnfolding :: CoreExpr -> Unfolding +mkInlineUnfolding expr + = mkCoreUnfolding InlineStable + True -- Note [Top-level flag on inline rules] + expr' guide + where + expr' = simpleOptExpr unsafeGlobalDynFlags expr + guide = UnfWhen { ug_arity = manifestArity expr' + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boring_ok } + boring_ok = inlineBoringOk expr' + +-- | Make an unfolding that will be used once the RHS has been saturated +-- to the given arity. +mkInlineUnfoldingWithArity :: Arity -> CoreExpr -> Unfolding +mkInlineUnfoldingWithArity arity expr + = mkCoreUnfolding InlineStable + True -- Note [Top-level flag on inline rules] + expr' guide + where + expr' = simpleOptExpr unsafeGlobalDynFlags expr + guide = UnfWhen { ug_arity = arity + , ug_unsat_ok = needSaturated + , ug_boring_ok = boring_ok } + -- See Note [INLINE pragmas and boring contexts] as to why we need to look + -- at the arity here. + boring_ok | arity == 0 = True + | otherwise = inlineBoringOk expr' + +mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding +mkInlinableUnfolding dflags expr + = mkUnfolding dflags InlineStable False False expr' + where + expr' = simpleOptExpr dflags expr + +specUnfolding :: DynFlags -> [Var] -> (CoreExpr -> CoreExpr) -> Arity + -> Unfolding -> Unfolding +-- See Note [Specialising unfoldings] +-- specUnfolding spec_bndrs spec_app arity_decrease unf +-- = \spec_bndrs. spec_app( unf ) +-- +specUnfolding dflags spec_bndrs spec_app arity_decrease + df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args }) + = ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs, ppr df ) + mkDFunUnfolding spec_bndrs con (map spec_arg args) + -- There is a hard-to-check assumption here that the spec_app has + -- enough applications to exactly saturate the old_bndrs + -- For DFunUnfoldings we transform + -- \old_bndrs. MkD <op1> ... <opn> + -- to + -- \new_bndrs. MkD (spec_app(\old_bndrs. <op1>)) ... ditto <opn> + -- The ASSERT checks the value part of that + where + spec_arg arg = simpleOptExpr dflags (spec_app (mkLams old_bndrs arg)) + -- The beta-redexes created by spec_app will be + -- simplified away by simplOptExpr + +specUnfolding dflags spec_bndrs spec_app arity_decrease + (CoreUnfolding { uf_src = src, uf_tmpl = tmpl + , uf_is_top = top_lvl + , uf_guidance = old_guidance }) + | isStableSource src -- See Note [Specialising unfoldings] + , UnfWhen { ug_arity = old_arity + , ug_unsat_ok = unsat_ok + , ug_boring_ok = boring_ok } <- old_guidance + = let guidance = UnfWhen { ug_arity = old_arity - arity_decrease + , ug_unsat_ok = unsat_ok + , ug_boring_ok = boring_ok } + new_tmpl = simpleOptExpr dflags (mkLams spec_bndrs (spec_app tmpl)) + -- The beta-redexes created by spec_app will be + -- simplified away by simplOptExpr + + in mkCoreUnfolding src top_lvl new_tmpl guidance + +specUnfolding _ _ _ _ _ = noUnfolding + +{- Note [Specialising unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise a function for some given type-class arguments, we use +specUnfolding to specialise its unfolding. Some important points: + +* If the original function has a DFunUnfolding, the specialised one + must do so too! Otherwise we lose the magic rules that make it + interact with ClassOps + +* There is a bit of hack for INLINABLE functions: + f :: Ord a => .... + f = <big-rhs> + {- INLINABLE f #-} + Now if we specialise f, should the specialised version still have + an INLINABLE pragma? If it does, we'll capture a specialised copy + of <big-rhs> as its unfolding, and that probably won't inline. But + if we don't, the specialised version of <big-rhs> might be small + enough to inline at a call site. This happens with Control.Monad.liftM3, + and can cause a lot more allocation as a result (nofib n-body shows this). + + Moreover, keeping the INLINABLE thing isn't much help, because + the specialised function (probably) isn't overloaded any more. + + Conclusion: drop the INLINEALE pragma. In practice what this means is: + if a stable unfolding has UnfoldingGuidance of UnfWhen, + we keep it (so the specialised thing too will always inline) + if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs + (which arises from INLINABLE), we discard it + +Note [Honour INLINE on 0-ary bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + x = <expensive> + {-# INLINE x #-} + + f y = ...x... + +The semantics of an INLINE pragma is + + inline x at every call site, provided it is saturated; + that is, applied to at least as many arguments as appear + on the LHS of the Haskell source definition. + +(This source-code-derived arity is stored in the `ug_arity` field of +the `UnfoldingGuidance`.) + +In the example, x's ug_arity is 0, so we should inline it at every use +site. It's rare to have such an INLINE pragma (usually INLINE Is on +functions), but it's occasionally very important (#15578, #15519). +In #15519 we had something like + x = case (g a b) of I# r -> T r + {-# INLINE x #-} + f y = ...(h x).... + +where h is strict. So we got + f y = ...(case g a b of I# r -> h (T r))... + +and that in turn allowed SpecConstr to ramp up performance. + +How do we deliver on this? By adjusting the ug_boring_ok +flag in mkInlineUnfoldingWithArity; see +Note [INLINE pragmas and boring contexts] + +NB: there is a real risk that full laziness will float it right back +out again. Consider again + x = factorial 200 + {-# INLINE x #-} + f y = ...x... + +After inlining we get + f y = ...(factorial 200)... + +but it's entirely possible that full laziness will do + lvl23 = factorial 200 + f y = ...lvl23... + +That's a problem for another day. + +Note [INLINE pragmas and boring contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An INLINE pragma uses mkInlineUnfoldingWithArity to build the +unfolding. That sets the ug_boring_ok flag to False if the function +is not tiny (inlineBoringOK), so that even INLINE functions are not +inlined in an utterly boring context. E.g. + \x y. Just (f y x) +Nothing is gained by inlining f here, even if it has an INLINE +pragma. + +But for 0-ary bindings, we want to inline regardless; see +Note [Honour INLINE on 0-ary bindings]. + +I'm a bit worried that it's possible for the same kind of problem +to arise for non-0-ary functions too, but let's wait and see. +-} + +mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr + -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it +mkCoreUnfolding src top_lvl expr guidance + = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr, + -- See Note [Occurrence analysis of unfoldings] + uf_src = src, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_is_work_free = exprIsWorkFree expr, + uf_expandable = exprIsExpandable expr, + uf_guidance = guidance } + +mkUnfolding :: DynFlags -> UnfoldingSource + -> Bool -- Is top-level + -> Bool -- Definitely a bottoming binding + -- (only relevant for top-level bindings) + -> CoreExpr + -> Unfolding +-- Calculates unfolding guidance +-- Occurrence-analyses the expression before capturing it +mkUnfolding dflags src is_top_lvl is_bottoming expr + = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr, + -- See Note [Occurrence analysis of unfoldings] + uf_src = src, + uf_is_top = is_top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_expandable = exprIsExpandable expr, + uf_is_work_free = exprIsWorkFree expr, + uf_guidance = guidance } + where + is_top_bottoming = is_top_lvl && is_bottoming + guidance = calcUnfoldingGuidance dflags is_top_bottoming expr + -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr_NoBinderSwap expr))! + -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] + +{- +Note [Occurrence analysis of unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do occurrence-analysis of unfoldings once and for all, when the +unfolding is built, rather than each time we inline them. + +But given this decision it's vital that we do +*always* do it. Consider this unfolding + \x -> letrec { f = ...g...; g* = f } in body +where g* is (for some strange reason) the loop breaker. If we don't +occ-anal it when reading it in, we won't mark g as a loop breaker, and +we may inline g entirely in body, dropping its binding, and leaving +the occurrence in f out of scope. This happened in #8892, where +the unfolding in question was a DFun unfolding. + +But more generally, the simplifier is designed on the +basis that it is looking at occurrence-analysed expressions, so better +ensure that they actually are. + +We use occurAnalyseExpr_NoBinderSwap instead of occurAnalyseExpr; +see Note [No binder swap in unfoldings]. + +Note [No binder swap in unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binder swap can temporarily violate Core Lint, by assigning +a LocalId binding to a GlobalId. For example, if A.foo{r872} +is a GlobalId with unique r872, then + + case A.foo{r872} of bar { + K x -> ...(A.foo{r872})... + } + +gets transformed to + + case A.foo{r872} of bar { + K x -> let foo{r872} = bar + in ...(A.foo{r872})... + +This is usually not a problem, because the simplifier will transform +this to: + + case A.foo{r872} of bar { + K x -> ...(bar)... + +However, after occurrence analysis but before simplification, this extra 'let' +violates the Core Lint invariant that we do not have local 'let' bindings for +GlobalIds. That seems (just) tolerable for the occurrence analysis that happens +just before the Simplifier, but not for unfoldings, which are Linted +independently. +As a quick workaround, we disable binder swap in this module. +See #16288 and #16296 for further plans. + +Note [Calculate unfolding guidance on the non-occ-anal'd expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we give the non-occur-analysed expression to +calcUnfoldingGuidance. In some ways it'd be better to occur-analyse +first; for example, sometimes during simplification, there's a large +let-bound thing which has been substituted, and so is now dead; so +'expr' contains two copies of the thing while the occurrence-analysed +expression doesn't. + +Nevertheless, we *don't* and *must not* occ-analyse before computing +the size because + +a) The size computation bales out after a while, whereas occurrence + analysis does not. + +b) Residency increases sharply if you occ-anal first. I'm not + 100% sure why, but it's a large effect. Compiling Cabal went + from residency of 534M to over 800M with this one change. + +This can occasionally mean that the guidance is very pessimistic; +it gets fixed up next round. And it should be rare, because large +let-bound things that are dead are usually caught by preInlineUnconditionally + + +************************************************************************ +* * +\subsection{The UnfoldingGuidance type} +* * +************************************************************************ +-} + +inlineBoringOk :: CoreExpr -> Bool +-- See Note [INLINE for small functions] +-- True => the result of inlining the expression is +-- no bigger than the expression itself +-- eg (\x y -> f y x) +-- This is a quick and dirty version. It doesn't attempt +-- to deal with (\x y z -> x (y z)) +-- The really important one is (x `cast` c) +inlineBoringOk e + = go 0 e + where + go :: Int -> CoreExpr -> Bool + go credit (Lam x e) | isId x = go (credit+1) e + | otherwise = go credit e + -- See Note [Count coercion arguments in boring contexts] + go credit (App f (Type {})) = go credit f + go credit (App f a) | credit > 0 + , exprIsTrivial a = go (credit-1) f + go credit (Tick _ e) = go credit e -- dubious + go credit (Cast e _) = go credit e + go _ (Var {}) = boringCxtOk + go _ _ = boringCxtNotOk + +calcUnfoldingGuidance + :: DynFlags + -> Bool -- Definitely a top-level, bottoming binding + -> CoreExpr -- Expression to look at + -> UnfoldingGuidance +calcUnfoldingGuidance dflags is_top_bottoming (Tick t expr) + | not (tickishIsCode t) -- non-code ticks don't matter for unfolding + = calcUnfoldingGuidance dflags is_top_bottoming expr +calcUnfoldingGuidance dflags is_top_bottoming expr + = case sizeExpr dflags bOMB_OUT_SIZE val_bndrs body of + TooBig -> UnfNever + SizeIs size cased_bndrs scrut_discount + | uncondInline expr n_val_bndrs size + -> UnfWhen { ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boringCxtOk + , ug_arity = n_val_bndrs } -- Note [INLINE for small functions] + + | is_top_bottoming + -> UnfNever -- See Note [Do not inline top-level bottoming functions] + + | otherwise + -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs + , ug_size = size + , ug_res = scrut_discount } + + where + (bndrs, body) = collectBinders expr + bOMB_OUT_SIZE = ufCreationThreshold dflags + -- Bomb out if size gets bigger than this + val_bndrs = filter isId bndrs + n_val_bndrs = length val_bndrs + + mk_discount :: Bag (Id,Int) -> Id -> Int + mk_discount cbs bndr = foldl' combine 0 cbs + where + combine acc (bndr', disc) + | bndr == bndr' = acc `plus_disc` disc + | otherwise = acc + + plus_disc :: Int -> Int -> Int + plus_disc | isFunTy (idType bndr) = max + | otherwise = (+) + -- See Note [Function and non-function discounts] + +{- +Note [Computing the size of an expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of sizeExpr is obvious enough: count nodes. But getting the +heuristics right has taken a long time. Here's the basic strategy: + + * Variables, literals: 0 + (Exception for string literals, see litSize.) + + * Function applications (f e1 .. en): 1 + #value args + + * Constructor applications: 1, regardless of #args + + * Let(rec): 1 + size of components + + * Note, cast: 0 + +Examples + + Size Term + -------------- + 0 42# + 0 x + 0 True + 2 f x + 1 Just x + 4 f (g x) + +Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's +a function call to account for. Notice also that constructor applications +are very cheap, because exposing them to a caller is so valuable. + +[25/5/11] All sizes are now multiplied by 10, except for primops +(which have sizes like 1 or 4. This makes primops look fantastically +cheap, and seems to be almost universally beneficial. Done partly as a +result of #4978. + +Note [Do not inline top-level bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The FloatOut pass has gone to some trouble to float out calls to 'error' +and similar friends. See Note [Bottoming floats] in SetLevels. +Do not re-inline them! But we *do* still inline if they are very small +(the uncondInline stuff). + +Note [INLINE for small functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider {-# INLINE f #-} + f x = Just x + g y = f y +Then f's RHS is no larger than its LHS, so we should inline it into +even the most boring context. In general, f the function is +sufficiently small that its body is as small as the call itself, the +inline unconditionally, regardless of how boring the context is. + +Things to note: + +(1) We inline *unconditionally* if inlined thing is smaller (using sizeExpr) + than the thing it's replacing. Notice that + (f x) --> (g 3) -- YES, unconditionally + (f x) --> x : [] -- YES, *even though* there are two + -- arguments to the cons + x --> g 3 -- NO + x --> Just v -- NO + + It's very important not to unconditionally replace a variable by + a non-atomic term. + +(2) We do this even if the thing isn't saturated, else we end up with the + silly situation that + f x y = x + ...map (f 3)... + doesn't inline. Even in a boring context, inlining without being + saturated will give a lambda instead of a PAP, and will be more + efficient at runtime. + +(3) However, when the function's arity > 0, we do insist that it + has at least one value argument at the call site. (This check is + made in the UnfWhen case of callSiteInline.) Otherwise we find this: + f = /\a \x:a. x + d = /\b. MkD (f b) + If we inline f here we get + d = /\b. MkD (\x:b. x) + and then prepareRhs floats out the argument, abstracting the type + variables, so we end up with the original again! + +(4) We must be much more cautious about arity-zero things. Consider + let x = y +# z in ... + In *size* terms primops look very small, because the generate a + single instruction, but we do not want to unconditionally replace + every occurrence of x with (y +# z). So we only do the + unconditional-inline thing for *trivial* expressions. + + NB: you might think that PostInlineUnconditionally would do this + but it doesn't fire for top-level things; see SimplUtils + Note [Top level and postInlineUnconditionally] + +Note [Count coercion arguments in boring contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In inlineBoringOK, we ignore type arguments when deciding whether an +expression is okay to inline into boring contexts. This is good, since +if we have a definition like + + let y = x @Int in f y y + +there’s no reason not to inline y at both use sites — no work is +actually duplicated. It may seem like the same reasoning applies to +coercion arguments, and indeed, in #17182 we changed inlineBoringOK to +treat coercions the same way. + +However, this isn’t a good idea: unlike type arguments, which have +no runtime representation, coercion arguments *do* have a runtime +representation (albeit the zero-width VoidRep, see Note [Coercion tokens] +in CoreToStg.hs). This caused trouble in #17787 for DataCon wrappers for +nullary GADT constructors: the wrappers would be inlined and each use of +the constructor would lead to a separate allocation instead of just +sharing the wrapper closure. + +The solution: don’t ignore coercion arguments after all. +-} + +uncondInline :: CoreExpr -> Arity -> Int -> Bool +-- Inline unconditionally if there no size increase +-- Size of call is arity (+1 for the function) +-- See Note [INLINE for small functions] +uncondInline rhs arity size + | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1) + | otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4) + +sizeExpr :: DynFlags + -> Int -- Bomb out if it gets bigger than this + -> [Id] -- Arguments; we're interested in which of these + -- get case'd + -> CoreExpr + -> ExprSize + +-- Note [Computing the size of an expression] + +sizeExpr dflags bOMB_OUT_SIZE top_args expr + = size_up expr + where + size_up (Cast e _) = size_up e + size_up (Tick _ e) = size_up e + size_up (Type _) = sizeZero -- Types cost nothing + size_up (Coercion _) = sizeZero + size_up (Lit lit) = sizeN (litSize lit) + size_up (Var f) | isRealWorldId f = sizeZero + -- Make sure we get constructor discounts even + -- on nullary constructors + | otherwise = size_up_call f [] 0 + + size_up (App fun arg) + | isTyCoArg arg = size_up fun + | otherwise = size_up arg `addSizeNSD` + size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0) + + size_up (Lam b e) + | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10) + | otherwise = size_up e + + size_up (Let (NonRec binder rhs) body) + = size_up_rhs (binder, rhs) `addSizeNSD` + size_up body `addSizeN` + size_up_alloc binder + + size_up (Let (Rec pairs) body) + = foldr (addSizeNSD . size_up_rhs) + (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs)) + pairs + + size_up (Case e _ _ alts) + | null alts + = size_up e -- case e of {} never returns, so take size of scrutinee + + size_up (Case e _ _ alts) + -- Now alts is non-empty + | Just v <- is_top_arg e -- We are scrutinising an argument variable + = let + alt_sizes = map size_up_alt alts + + -- alts_size tries to compute a good discount for + -- the case when we are scrutinising an argument variable + alts_size (SizeIs tot tot_disc tot_scrut) + -- Size of all alternatives + (SizeIs max _ _) + -- Size of biggest alternative + = SizeIs tot (unitBag (v, 20 + tot - max) + `unionBags` tot_disc) tot_scrut + -- If the variable is known, we produce a + -- discount that will take us back to 'max', + -- the size of the largest alternative The + -- 1+ is a little discount for reduced + -- allocation in the caller + -- + -- Notice though, that we return tot_disc, + -- the total discount from all branches. I + -- think that's right. + + alts_size tot_size _ = tot_size + in + alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty + (foldr1 maxSize alt_sizes) + -- Good to inline if an arg is scrutinised, because + -- that may eliminate allocation in the caller + -- And it eliminates the case itself + where + is_top_arg (Var v) | v `elem` top_args = Just v + is_top_arg (Cast e _) = is_top_arg e + is_top_arg _ = Nothing + + + size_up (Case e _ _ alts) = size_up e `addSizeNSD` + foldr (addAltSize . size_up_alt) case_size alts + where + case_size + | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10) + | otherwise = sizeZero + -- Normally we don't charge for the case itself, but + -- we charge one per alternative (see size_up_alt, + -- below) to account for the cost of the info table + -- and comparisons. + -- + -- However, in certain cases (see is_inline_scrut + -- below), no code is generated for the case unless + -- there are multiple alts. In these cases we + -- subtract one, making the first alt free. + -- e.g. case x# +# y# of _ -> ... should cost 1 + -- case touch# x# of _ -> ... should cost 0 + -- (see #4978) + -- + -- I would like to not have the "lengthAtMost alts 1" + -- condition above, but without that some programs got worse + -- (spectral/hartel/event and spectral/para). I don't fully + -- understand why. (SDM 24/5/11) + + -- unboxed variables, inline primops and unsafe foreign calls + -- are all "inline" things: + is_inline_scrut (Var v) = isUnliftedType (idType v) + is_inline_scrut scrut + | (Var f, _) <- collectArgs scrut + = case idDetails f of + FCallId fc -> not (isSafeForeignCall fc) + PrimOpId op -> not (primOpOutOfLine op) + _other -> False + | otherwise + = False + + size_up_rhs (bndr, rhs) + | Just join_arity <- isJoinId_maybe bndr + -- Skip arguments to join point + , (_bndrs, body) <- collectNBinders join_arity rhs + = size_up body + | otherwise + = size_up rhs + + ------------ + -- size_up_app is used when there's ONE OR MORE value args + size_up_app (App fun arg) args voids + | isTyCoArg arg = size_up_app fun args voids + | isRealWorldExpr arg = size_up_app fun (arg:args) (voids + 1) + | otherwise = size_up arg `addSizeNSD` + size_up_app fun (arg:args) voids + size_up_app (Var fun) args voids = size_up_call fun args voids + size_up_app (Tick _ expr) args voids = size_up_app expr args voids + size_up_app (Cast expr _) args voids = size_up_app expr args voids + size_up_app other args voids = size_up other `addSizeN` + callSize (length args) voids + -- if the lhs is not an App or a Var, or an invisible thing like a + -- Tick or Cast, then we should charge for a complete call plus the + -- size of the lhs itself. + + ------------ + size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize + size_up_call fun val_args voids + = case idDetails fun of + FCallId _ -> sizeN (callSize (length val_args) voids) + DataConWorkId dc -> conSize dc (length val_args) + PrimOpId op -> primOpSize op (length val_args) + ClassOpId _ -> classOpSize dflags top_args val_args + _ -> funSize dflags top_args fun (length val_args) voids + + ------------ + size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 + -- Don't charge for args, so that wrappers look cheap + -- (See comments about wrappers with Case) + -- + -- IMPORTANT: *do* charge 1 for the alternative, else we + -- find that giant case nests are treated as practically free + -- A good example is Foreign.C.Error.errnoToIOError + + ------------ + -- Cost to allocate binding with given binder + size_up_alloc bndr + | isTyVar bndr -- Doesn't exist at runtime + || isJoinId bndr -- Not allocated at all + || isUnliftedType (idType bndr) -- Doesn't live in heap + = 0 + | otherwise + = 10 + + ------------ + -- These addSize things have to be here because + -- I don't want to give them bOMB_OUT_SIZE as an argument + addSizeN TooBig _ = TooBig + addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n + m) xs d + + -- addAltSize is used to add the sizes of case alternatives + addAltSize TooBig _ = TooBig + addAltSize _ TooBig = TooBig + addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) + = mkSizeIs bOMB_OUT_SIZE (n1 + n2) + (xs `unionBags` ys) + (d1 + d2) -- Note [addAltSize result discounts] + + -- This variant ignores the result discount from its LEFT argument + -- It's used when the second argument isn't part of the result + addSizeNSD TooBig _ = TooBig + addSizeNSD _ TooBig = TooBig + addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2) + = mkSizeIs bOMB_OUT_SIZE (n1 + n2) + (xs `unionBags` ys) + d2 -- Ignore d1 + + isRealWorldId id = idType id `eqType` realWorldStatePrimTy + + -- an expression of type State# RealWorld must be a variable + isRealWorldExpr (Var id) = isRealWorldId id + isRealWorldExpr (Tick _ e) = isRealWorldExpr e + isRealWorldExpr _ = False + +-- | Finds a nominal size of a string literal. +litSize :: Literal -> Int +-- Used by GHC.Core.Unfold.sizeExpr +litSize (LitNumber LitNumInteger _ _) = 100 -- Note [Size of literal integers] +litSize (LitNumber LitNumNatural _ _) = 100 +litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4) + -- If size could be 0 then @f "x"@ might be too small + -- [Sept03: make literal strings a bit bigger to avoid fruitless + -- duplication of little strings] +litSize _other = 0 -- Must match size of nullary constructors + -- Key point: if x |-> 4, then x must inline unconditionally + -- (eg via case binding) + +classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize +-- See Note [Conlike is interesting] +classOpSize _ _ [] + = sizeZero +classOpSize dflags top_args (arg1 : other_args) + = SizeIs size arg_discount 0 + where + size = 20 + (10 * length other_args) + -- If the class op is scrutinising a lambda bound dictionary then + -- give it a discount, to encourage the inlining of this function + -- The actual discount is rather arbitrarily chosen + arg_discount = case arg1 of + Var dict | dict `elem` top_args + -> unitBag (dict, ufDictDiscount dflags) + _other -> emptyBag + +-- | The size of a function call +callSize + :: Int -- ^ number of value args + -> Int -- ^ number of value args that are void + -> Int +callSize n_val_args voids = 10 * (1 + n_val_args - voids) + -- The 1+ is for the function itself + -- Add 1 for each non-trivial arg; + -- the allocation cost, as in let(rec) + +-- | The size of a jump to a join point +jumpSize + :: Int -- ^ number of value args + -> Int -- ^ number of value args that are void + -> Int +jumpSize n_val_args voids = 2 * (1 + n_val_args - voids) + -- A jump is 20% the size of a function call. Making jumps free reopens + -- bug #6048, but making them any more expensive loses a 21% improvement in + -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a + -- better solution? + +funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize +-- Size for functions that are not constructors or primops +-- Note [Function applications] +funSize dflags top_args fun n_val_args voids + | fun `hasKey` buildIdKey = buildSize + | fun `hasKey` augmentIdKey = augmentSize + | otherwise = SizeIs size arg_discount res_discount + where + some_val_args = n_val_args > 0 + is_join = isJoinId fun + + size | is_join = jumpSize n_val_args voids + | not some_val_args = 0 + | otherwise = callSize n_val_args voids + + -- DISCOUNTS + -- See Note [Function and non-function discounts] + arg_discount | some_val_args && fun `elem` top_args + = unitBag (fun, ufFunAppDiscount dflags) + | otherwise = emptyBag + -- If the function is an argument and is applied + -- to some values, give it an arg-discount + + res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags + | otherwise = 0 + -- If the function is partially applied, show a result discount +-- XXX maybe behave like ConSize for eval'd variable + +conSize :: DataCon -> Int -> ExprSize +conSize dc n_val_args + | n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables + +-- See Note [Unboxed tuple size and result discount] + | isUnboxedTupleCon dc = SizeIs 0 emptyBag (10 * (1 + n_val_args)) + +-- See Note [Constructor size and result discount] + | otherwise = SizeIs 10 emptyBag (10 * (1 + n_val_args)) + +-- XXX still looks to large to me + +{- +Note [Constructor size and result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Treat a constructors application as size 10, regardless of how many +arguments it has; we are keen to expose them (and we charge separately +for their args). We can't treat them as size zero, else we find that +(Just x) has size 0, which is the same as a lone variable; and hence +'v' will always be replaced by (Just x), where v is bound to Just x. + +The "result discount" is applied if the result of the call is +scrutinised (say by a case). For a constructor application that will +mean the constructor application will disappear, so we don't need to +charge it to the function. So the discount should at least match the +cost of the constructor application, namely 10. But to give a bit +of extra incentive we give a discount of 10*(1 + n_val_args). + +Simon M tried a MUCH bigger discount: (10 * (10 + n_val_args)), +and said it was an "unambiguous win", but its terribly dangerous +because a function with many many case branches, each finishing with +a constructor, can have an arbitrarily large discount. This led to +terrible code bloat: see #6099. + +Note [Unboxed tuple size and result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +However, unboxed tuples count as size zero. I found occasions where we had + f x y z = case op# x y z of { s -> (# s, () #) } +and f wasn't getting inlined. + +I tried giving unboxed tuples a *result discount* of zero (see the +commented-out line). Why? When returned as a result they do not +allocate, so maybe we don't want to charge so much for them If you +have a non-zero discount here, we find that workers often get inlined +back into wrappers, because it look like + f x = case $wf x of (# a,b #) -> (a,b) +and we are keener because of the case. However while this change +shrank binary sizes by 0.5% it also made spectral/boyer allocate 5% +more. All other changes were very small. So it's not a big deal but I +didn't adopt the idea. + +Note [Function and non-function discounts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want a discount if the function is applied. A good example is +monadic combinators with continuation arguments, where inlining is +quite important. + +But we don't want a big discount when a function is called many times +(see the detailed comments with #6048) because if the function is +big it won't be inlined at its many call sites and no benefit results. +Indeed, we can get exponentially big inlinings this way; that is what +#6048 is about. + +On the other hand, for data-valued arguments, if there are lots of +case expressions in the body, each one will get smaller if we apply +the function to a constructor application, so we *want* a big discount +if the argument is scrutinised by many case expressions. + +Conclusion: + - For functions, take the max of the discounts + - For data values, take the sum of the discounts + + +Note [Literal integer size] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Literal integers *can* be big (mkInteger [...coefficients...]), but +need not be (S# n). We just use an arbitrary big-ish constant here +so that, in particular, we don't inline top-level defns like + n = S# 5 +There's no point in doing so -- any optimisations will see the S# +through n's unfolding. Nor will a big size inhibit unfoldings functions +that mention a literal Integer, because the float-out pass will float +all those constants to top level. +-} + +primOpSize :: PrimOp -> Int -> ExprSize +primOpSize op n_val_args + = if primOpOutOfLine op + then sizeN (op_size + n_val_args) + else sizeN op_size + where + op_size = primOpCodeSize op + + +buildSize :: ExprSize +buildSize = SizeIs 0 emptyBag 40 + -- We really want to inline applications of build + -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later) + -- Indeed, we should add a result_discount because build is + -- very like a constructor. We don't bother to check that the + -- build is saturated (it usually is). The "-2" discounts for the \c n, + -- The "4" is rather arbitrary. + +augmentSize :: ExprSize +augmentSize = SizeIs 0 emptyBag 40 + -- Ditto (augment t (\cn -> e) ys) should cost only the cost of + -- e plus ys. The -2 accounts for the \cn + +-- When we return a lambda, give a discount if it's used (applied) +lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize +lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (ufFunAppDiscount dflags) +lamScrutDiscount _ TooBig = TooBig + +{- +Note [addAltSize result discounts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When adding the size of alternatives, we *add* the result discounts +too, rather than take the *maximum*. For a multi-branch case, this +gives a discount for each branch that returns a constructor, making us +keener to inline. I did try using 'max' instead, but it makes nofib +'rewrite' and 'puzzle' allocate significantly more, and didn't make +binary sizes shrink significantly either. + +Note [Discounts and thresholds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constants for discounts and thesholds are defined in main/DynFlags, +all of form ufXxxx. They are: + +ufCreationThreshold + At a definition site, if the unfolding is bigger than this, we + may discard it altogether + +ufUseThreshold + At a call site, if the unfolding, less discounts, is smaller than + this, then it's small enough inline + +ufKeenessFactor + Factor by which the discounts are multiplied before + subtracting from size + +ufDictDiscount + The discount for each occurrence of a dictionary argument + as an argument of a class method. Should be pretty small + else big functions may get inlined + +ufFunAppDiscount + Discount for a function argument that is applied. Quite + large, because if we inline we avoid the higher-order call. + +ufDearOp + The size of a foreign call or not-dupable PrimOp + +ufVeryAggressive + If True, the compiler ignores all the thresholds and inlines very + aggressively. It still adheres to arity, simplifier phase control and + loop breakers. + + +Note [Function applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a function application (f a b) + + - If 'f' is an argument to the function being analysed, + and there's at least one value arg, record a FunAppDiscount for f + + - If the application if a PAP (arity > 2 in this example) + record a *result* discount (because inlining + with "extra" args in the call may mean that we now + get a saturated application) + +Code for manipulating sizes +-} + +-- | The size of a candidate expression for unfolding +data ExprSize + = TooBig + | SizeIs { _es_size_is :: {-# UNPACK #-} !Int -- ^ Size found + , _es_args :: !(Bag (Id,Int)) + -- ^ Arguments cased herein, and discount for each such + , _es_discount :: {-# UNPACK #-} !Int + -- ^ Size to subtract if result is scrutinised by a case + -- expression + } + +instance Outputable ExprSize where + ppr TooBig = text "TooBig" + ppr (SizeIs a _ c) = brackets (int a <+> int c) + +-- subtract the discount before deciding whether to bale out. eg. we +-- want to inline a large constructor application into a selector: +-- tup = (a_1, ..., a_99) +-- x = case tup of ... +-- +mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize +mkSizeIs max n xs d | (n - d) > max = TooBig + | otherwise = SizeIs n xs d + +maxSize :: ExprSize -> ExprSize -> ExprSize +maxSize TooBig _ = TooBig +maxSize _ TooBig = TooBig +maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2 = s1 + | otherwise = s2 + +sizeZero :: ExprSize +sizeN :: Int -> ExprSize + +sizeZero = SizeIs 0 emptyBag 0 +sizeN n = SizeIs n emptyBag 0 + +{- +************************************************************************ +* * +\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} +* * +************************************************************************ + +We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that +we ``couldn't possibly use'' on the other side. Can be overridden w/ +flaggery. Just the same as smallEnoughToInline, except that it has no +actual arguments. +-} + +couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool +couldBeSmallEnoughToInline dflags threshold rhs + = case sizeExpr dflags threshold [] body of + TooBig -> False + _ -> True + where + (_, body) = collectBinders rhs + +---------------- +smallEnoughToInline :: DynFlags -> Unfolding -> Bool +smallEnoughToInline dflags (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}}) + = size <= ufUseThreshold dflags +smallEnoughToInline _ _ + = False + +---------------- + +certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding +-- ^ Sees if the unfolding is pretty certain to inline. +-- If so, return a *stable* unfolding for it, that will always inline. +certainlyWillInline dflags fn_info + = case unfoldingInfo fn_info of + CoreUnfolding { uf_tmpl = e, uf_guidance = g } + | loop_breaker -> Nothing -- Won't inline, so try w/w + | noinline -> Nothing -- See Note [Worker-wrapper for NOINLINE functions] + | otherwise -> do_cunf e g -- Depends on size, so look at that + + DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense + -- to do so, and even if it is currently a + -- loop breaker, it may not be later + + _other_unf -> Nothing + + where + loop_breaker = isStrongLoopBreaker (occInfo fn_info) + noinline = inlinePragmaSpec (inlinePragInfo fn_info) == NoInline + fn_unf = unfoldingInfo fn_info + + do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding + do_cunf _ UnfNever = Nothing + do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable }) + -- INLINE functions have UnfWhen + + -- The UnfIfGoodArgs case seems important. If we w/w small functions + -- binary sizes go up by 10%! (This is with SplitObjs.) + -- I'm not totally sure why. + -- INLINABLE functions come via this path + -- See Note [certainlyWillInline: INLINABLE] + do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args }) + | arityInfo fn_info > 0 -- See Note [certainlyWillInline: be careful of thunks] + , not (isBottomingSig (strictnessInfo fn_info)) + -- Do not unconditionally inline a bottoming functions even if + -- it seems smallish. We've carefully lifted it out to top level, + -- so we don't want to re-inline it. + , let unf_arity = length args + , size - (10 * (unf_arity + 1)) <= ufUseThreshold dflags + = Just (fn_unf { uf_src = InlineStable + , uf_guidance = UnfWhen { ug_arity = unf_arity + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = inlineBoringOk expr } }) + -- Note the "unsaturatedOk". A function like f = \ab. a + -- will certainly inline, even if partially applied (f e), so we'd + -- better make sure that the transformed inlining has the same property + | otherwise + = Nothing + +{- Note [certainlyWillInline: be careful of thunks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't claim that thunks will certainly inline, because that risks work +duplication. Even if the work duplication is not great (eg is_cheap +holds), it can make a big difference in an inner loop In #5623 we +found that the WorkWrap phase thought that + y = case x of F# v -> F# (v +# v) +was certainlyWillInline, so the addition got duplicated. + +Note that we check arityInfo instead of the arity of the unfolding to detect +this case. This is so that we don't accidentally fail to inline small partial +applications, like `f = g 42` (where `g` recurses into `f`) where g has arity 2 +(say). Here there is no risk of work duplication, and the RHS is tiny, so +certainlyWillInline should return True. But `unf_arity` is zero! However f's +arity, gotten from `arityInfo fn_info`, is 1. + +Failing to say that `f` will inline forces W/W to generate a potentially huge +worker for f that will immediately cancel with `g`'s wrapper anyway, causing +unnecessary churn in the Simplifier while arriving at the same result. + +Note [certainlyWillInline: INLINABLE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +certainlyWillInline /must/ return Nothing for a large INLINABLE thing, +even though we have a stable inlining, so that strictness w/w takes +place. It makes a big difference to efficiency, and the w/w pass knows +how to transfer the INLINABLE info to the worker; see WorkWrap +Note [Worker-wrapper for INLINABLE functions] + +************************************************************************ +* * +\subsection{callSiteInline} +* * +************************************************************************ + +This is the key function. It decides whether to inline a variable at a call site + +callSiteInline is used at call sites, so it is a bit more generous. +It's a very important function that embodies lots of heuristics. +A non-WHNF can be inlined if it doesn't occur inside a lambda, +and occurs exactly once or + occurs once in each branch of a case and is small + +If the thing is in WHNF, there's no danger of duplicating work, +so we can inline if it occurs once, or is small + +NOTE: we don't want to inline top-level functions that always diverge. +It just makes the code bigger. Tt turns out that the convenient way to prevent +them inlining is to give them a NOINLINE pragma, which we do in +StrictAnal.addStrictnessInfoToTopId +-} + +callSiteInline :: DynFlags + -> Id -- The Id + -> Bool -- True <=> unfolding is active + -> Bool -- True if there are no arguments at all (incl type args) + -> [ArgSummary] -- One for each value arg; True if it is interesting + -> CallCtxt -- True <=> continuation is interesting + -> Maybe CoreExpr -- Unfolding, if any + +data ArgSummary = TrivArg -- Nothing interesting + | NonTrivArg -- Arg has structure + | ValueArg -- Arg is a con-app or PAP + -- ..or con-like. Note [Conlike is interesting] + +instance Outputable ArgSummary where + ppr TrivArg = text "TrivArg" + ppr NonTrivArg = text "NonTrivArg" + ppr ValueArg = text "ValueArg" + +nonTriv :: ArgSummary -> Bool +nonTriv TrivArg = False +nonTriv _ = True + +data CallCtxt + = BoringCtxt + | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets] + | DiscArgCtxt -- Argument of a function with non-zero arg discount + | RuleArgCtxt -- We are somewhere in the argument of a function with rules + + | ValAppCtxt -- We're applied to at least one value arg + -- This arises when we have ((f x |> co) y) + -- Then the (f x) has argument 'x' but in a ValAppCtxt + + | CaseCtxt -- We're the scrutinee of a case + -- that decomposes its scrutinee + +instance Outputable CallCtxt where + ppr CaseCtxt = text "CaseCtxt" + ppr ValAppCtxt = text "ValAppCtxt" + ppr BoringCtxt = text "BoringCtxt" + ppr RhsCtxt = text "RhsCtxt" + ppr DiscArgCtxt = text "DiscArgCtxt" + ppr RuleArgCtxt = text "RuleArgCtxt" + +callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info + = case idUnfolding id of + -- idUnfolding checks for loop-breakers, returning NoUnfolding + -- Things with an INLINE pragma may have an unfolding *and* + -- be a loop breaker (maybe the knot is not yet untied) + CoreUnfolding { uf_tmpl = unf_template + , uf_is_work_free = is_wf + , uf_guidance = guidance, uf_expandable = is_exp } + | active_unfolding -> tryUnfolding dflags id lone_variable + arg_infos cont_info unf_template + is_wf is_exp guidance + | otherwise -> traceInline dflags id "Inactive unfolding:" (ppr id) Nothing + NoUnfolding -> Nothing + BootUnfolding -> Nothing + OtherCon {} -> Nothing + DFunUnfolding {} -> Nothing -- Never unfold a DFun + +traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a +traceInline dflags inline_id str doc result + | Just prefix <- inlineCheck dflags + = if prefix `isPrefixOf` occNameString (getOccName inline_id) + then traceAction dflags str doc result + else result + | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags + = traceAction dflags str doc result + | otherwise + = result + +tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt + -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance + -> Maybe CoreExpr +tryUnfolding dflags id lone_variable + arg_infos cont_info unf_template + is_wf is_exp guidance + = case guidance of + UnfNever -> traceInline dflags id str (text "UnfNever") Nothing + + UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + | enough_args && (boring_ok || some_benefit || ufVeryAggressive dflags) + -- See Note [INLINE for small functions (3)] + -> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template) + | otherwise + -> traceInline dflags id str (mk_doc some_benefit empty False) Nothing + where + some_benefit = calc_some_benefit uf_arity + enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0) + + UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } + | ufVeryAggressive dflags + -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) + | is_wf && some_benefit && small_enough + -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) + | otherwise + -> traceInline dflags id str (mk_doc some_benefit extra_doc False) Nothing + where + some_benefit = calc_some_benefit (length arg_discounts) + extra_doc = text "discounted size =" <+> int discounted_size + discounted_size = size - discount + small_enough = discounted_size <= ufUseThreshold dflags + discount = computeDiscount dflags arg_discounts + res_discount arg_infos cont_info + + where + mk_doc some_benefit extra_doc yes_or_no + = vcat [ text "arg infos" <+> ppr arg_infos + , text "interesting continuation" <+> ppr cont_info + , text "some_benefit" <+> ppr some_benefit + , text "is exp:" <+> ppr is_exp + , text "is work-free:" <+> ppr is_wf + , text "guidance" <+> ppr guidance + , extra_doc + , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] + + str = "Considering inlining: " ++ showSDocDump dflags (ppr id) + n_val_args = length arg_infos + + -- some_benefit is used when the RHS is small enough + -- and the call has enough (or too many) value + -- arguments (ie n_val_args >= arity). But there must + -- be *something* interesting about some argument, or the + -- result context, to make it worth inlining + calc_some_benefit :: Arity -> Bool -- The Arity is the number of args + -- expected by the unfolding + calc_some_benefit uf_arity + | not saturated = interesting_args -- Under-saturated + -- Note [Unsaturated applications] + | otherwise = interesting_args -- Saturated or over-saturated + || interesting_call + where + saturated = n_val_args >= uf_arity + over_saturated = n_val_args > uf_arity + interesting_args = any nonTriv arg_infos + -- NB: (any nonTriv arg_infos) looks at the + -- over-saturated args too which is "wrong"; + -- but if over-saturated we inline anyway. + + interesting_call + | over_saturated + = True + | otherwise + = case cont_info of + CaseCtxt -> not (lone_variable && is_exp) -- Note [Lone variables] + ValAppCtxt -> True -- Note [Cast then apply] + RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts] + DiscArgCtxt -> uf_arity > 0 -- Note [Inlining in ArgCtxt] + RhsCtxt -> uf_arity > 0 -- + _other -> False -- See Note [Nested functions] + + +{- +Note [Unfold into lazy contexts], Note [RHS of lets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the call is the argument of a function with a RULE, or the RHS of a let, +we are a little bit keener to inline. For example + f y = (y,y,y) + g y = let x = f y in ...(case x of (a,b,c) -> ...) ... +We'd inline 'f' if the call was in a case context, and it kind-of-is, +only we can't see it. Also + x = f v +could be expensive whereas + x = case v of (a,b) -> a +is patently cheap and may allow more eta expansion. +So we treat the RHS of a let as not-totally-boring. + +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a call is not saturated, we *still* inline if one of the +arguments has interesting structure. That's sometimes very important. +A good example is the Ord instance for Bool in Base: + + Rec { + $fOrdBool =GHC.Classes.D:Ord + @ Bool + ... + $cmin_ajX + + $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool + $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool + } + +But the defn of GHC.Classes.$dmmin is: + + $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a + {- Arity: 3, HasNoCafRefs, Strictness: SLL, + Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> + case @ a GHC.Classes.<= @ a $dOrd x y of wild { + GHC.Types.False -> y GHC.Types.True -> x }) -} + +We *really* want to inline $dmmin, even though it has arity 3, in +order to unravel the recursion. + + +Note [Things to watch] +~~~~~~~~~~~~~~~~~~~~~~ +* { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } + Assume x is exported, so not inlined unconditionally. + Then we want x to inline unconditionally; no reason for it + not to, and doing so avoids an indirection. + +* { x = I# 3; ....f x.... } + Make sure that x does not inline unconditionally! + Lest we get extra allocation. + +Note [Inlining an InlineRule] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An InlineRules is used for + (a) programmer INLINE pragmas + (b) inlinings from worker/wrapper + +For (a) the RHS may be large, and our contract is that we *only* inline +when the function is applied to all the arguments on the LHS of the +source-code defn. (The uf_arity in the rule.) + +However for worker/wrapper it may be worth inlining even if the +arity is not satisfied (as we do in the CoreUnfolding case) so we don't +require saturation. + +Note [Nested functions] +~~~~~~~~~~~~~~~~~~~~~~~ +At one time we treated a call of a non-top-level function as +"interesting" (regardless of how boring the context) in the hope +that inlining it would eliminate the binding, and its allocation. +Specifically, in the default case of interesting_call we had + _other -> not is_top && uf_arity > 0 + +But actually postInlineUnconditionally does some of this and overall +it makes virtually no difference to nofib. So I simplified away this +special case + +Note [Cast then apply] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + myIndex = __inline_me ( (/\a. <blah>) |> co ) + co :: (forall a. a -> a) ~ (forall a. T a) + ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ... + +We need to inline myIndex to unravel this; but the actual call (myIndex a) has +no value arguments. The ValAppCtxt gives it enough incentive to inline. + +Note [Inlining in ArgCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The condition (arity > 0) here is very important, because otherwise +we end up inlining top-level stuff into useless places; eg + x = I# 3# + f = \y. g x +This can make a very big difference: it adds 16% to nofib 'integer' allocs, +and 20% to 'power'. + +At one stage I replaced this condition by 'True' (leading to the above +slow-down). The motivation was test eyeball/inline1.hs; but that seems +to work ok now. + +NOTE: arguably, we should inline in ArgCtxt only if the result of the +call is at least CONLIKE. At least for the cases where we use ArgCtxt +for the RHS of a 'let', we only profit from the inlining if we get a +CONLIKE thing (modulo lets). + +Note [Lone variables] See also Note [Interaction of exprIsWorkFree and lone variables] +~~~~~~~~~~~~~~~~~~~~~ which appears below +The "lone-variable" case is important. I spent ages messing about +with unsatisfactory variants, but this is nice. The idea is that if a +variable appears all alone + + as an arg of lazy fn, or rhs BoringCtxt + as scrutinee of a case CaseCtxt + as arg of a fn ArgCtxt +AND + it is bound to a cheap expression + +then we should not inline it (unless there is some other reason, +e.g. it is the sole occurrence). That is what is happening at +the use of 'lone_variable' in 'interesting_call'. + +Why? At least in the case-scrutinee situation, turning + let x = (a,b) in case x of y -> ... +into + let x = (a,b) in case (a,b) of y -> ... +and thence to + let x = (a,b) in let y = (a,b) in ... +is bad if the binding for x will remain. + +Another example: I discovered that strings +were getting inlined straight back into applications of 'error' +because the latter is strict. + s = "foo" + f = \x -> ...(error s)... + +Fundamentally such contexts should not encourage inlining because, provided +the RHS is "expandable" (see Note [exprIsExpandable] in GHC.Core.Utils) the +context can ``see'' the unfolding of the variable (e.g. case or a +RULE) so there's no gain. + +However, watch out: + + * Consider this: + foo = _inline_ (\n. [n]) + bar = _inline_ (foo 20) + baz = \n. case bar of { (m:_) -> m + n } + Here we really want to inline 'bar' so that we can inline 'foo' + and the whole thing unravels as it should obviously do. This is + important: in the NDP project, 'bar' generates a closure data + structure rather than a list. + + So the non-inlining of lone_variables should only apply if the + unfolding is regarded as cheap; because that is when exprIsConApp_maybe + looks through the unfolding. Hence the "&& is_wf" in the + InlineRule branch. + + * Even a type application or coercion isn't a lone variable. + Consider + case $fMonadST @ RealWorld of { :DMonad a b c -> c } + We had better inline that sucker! The case won't see through it. + + For now, I'm treating treating a variable applied to types + in a *lazy* context "lone". The motivating example was + f = /\a. \x. BIG + g = /\a. \y. h (f a) + There's no advantage in inlining f here, and perhaps + a significant disadvantage. Hence some_val_args in the Stop case + +Note [Interaction of exprIsWorkFree and lone variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lone-variable test says "don't inline if a case expression +scrutinises a lone variable whose unfolding is cheap". It's very +important that, under these circumstances, exprIsConApp_maybe +can spot a constructor application. So, for example, we don't +consider + let x = e in (x,x) +to be cheap, and that's good because exprIsConApp_maybe doesn't +think that expression is a constructor application. + +In the 'not (lone_variable && is_wf)' test, I used to test is_value +rather than is_wf, which was utterly wrong, because the above +expression responds True to exprIsHNF, which is what sets is_value. + +This kind of thing can occur if you have + + {-# INLINE foo #-} + foo = let x = e in (x,x) + +which Roman did. + + +-} + +computeDiscount :: DynFlags -> [Int] -> Int -> [ArgSummary] -> CallCtxt + -> Int +computeDiscount dflags arg_discounts res_discount arg_infos cont_info + -- We multiple the raw discounts (args_discount and result_discount) + -- ty opt_UnfoldingKeenessFactor because the former have to do with + -- *size* whereas the discounts imply that there's some extra + -- *efficiency* to be gained (e.g. beta reductions, case reductions) + -- by inlining. + + = 10 -- Discount of 10 because the result replaces the call + -- so we count 10 for the function itself + + + 10 * length actual_arg_discounts + -- Discount of 10 for each arg supplied, + -- because the result replaces the call + + + round (ufKeenessFactor dflags * + fromIntegral (total_arg_discount + res_discount')) + where + actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos + total_arg_discount = sum actual_arg_discounts + + mk_arg_discount _ TrivArg = 0 + mk_arg_discount _ NonTrivArg = 10 + mk_arg_discount discount ValueArg = discount + + res_discount' + | LT <- arg_discounts `compareLength` arg_infos + = res_discount -- Over-saturated + | otherwise + = case cont_info of + BoringCtxt -> 0 + CaseCtxt -> res_discount -- Presumably a constructor + ValAppCtxt -> res_discount -- Presumably a function + _ -> 40 `min` res_discount + -- ToDo: this 40 `min` res_discount doesn't seem right + -- for DiscArgCtxt it shouldn't matter because the function will + -- get the arg discount for any non-triv arg + -- for RuleArgCtxt we do want to be keener to inline; but not only + -- constructor results + -- for RhsCtxt I suppose that exposing a data con is good in general + -- And 40 seems very arbitrary + -- + -- res_discount can be very large when a function returns + -- constructors; but we only want to invoke that large discount + -- when there's a case continuation. + -- Otherwise we, rather arbitrarily, threshold it. Yuk. + -- But we want to avoid inlining large functions that return + -- constructors into contexts that are simply "interesting" diff --git a/compiler/GHC/Core/Unfold.hs-boot b/compiler/GHC/Core/Unfold.hs-boot new file mode 100644 index 0000000000..54895ae8b1 --- /dev/null +++ b/compiler/GHC/Core/Unfold.hs-boot @@ -0,0 +1,16 @@ +module GHC.Core.Unfold ( + mkUnfolding, mkInlineUnfolding + ) where + +import GhcPrelude +import GHC.Core +import GHC.Driver.Session + +mkInlineUnfolding :: CoreExpr -> Unfolding + +mkUnfolding :: DynFlags + -> UnfoldingSource + -> Bool + -> Bool + -> CoreExpr + -> Unfolding diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs new file mode 100644 index 0000000000..67ff7823e4 --- /dev/null +++ b/compiler/GHC/Core/Utils.hs @@ -0,0 +1,2567 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utility functions on @Core@ syntax +-} + +{-# LANGUAGE CPP #-} + +-- | Commonly useful utilities for manipulating the Core language +module GHC.Core.Utils ( + -- * Constructing expressions + mkCast, + mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, + bindNonRec, needsCaseBinding, + mkAltExpr, mkDefaultCase, mkSingleAltCase, + + -- * Taking expressions apart + findDefault, addDefault, findAlt, isDefaultAlt, + mergeAlts, trimConArgs, + filterAlts, combineIdenticalAlts, refineDefaultAlt, + + -- * Properties of expressions + exprType, coreAltType, coreAltsType, isExprLevPoly, + exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, + getIdFromTrivialExpr_maybe, + exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, + exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, + exprIsBig, exprIsConLike, + isCheapApp, isExpandableApp, + exprIsTickedString, exprIsTickedString_maybe, + exprIsTopLevelBindable, + altsAreExhaustive, + + -- * Equality + cheapEqExpr, cheapEqExpr', eqExpr, + diffExpr, diffBinds, + + -- * Eta reduction + tryEtaReduce, + + -- * Manipulating data constructors and types + exprToType, exprToCoercion_maybe, + applyTypeToArgs, applyTypeToArg, + dataConRepInstPat, dataConRepFSInstPat, + isEmptyTy, + + -- * Working with ticks + stripTicksTop, stripTicksTopE, stripTicksTopT, + stripTicksE, stripTicksT, + + -- * StaticPtr + collectMakeStaticArgs, + + -- * Join points + isJoinBind, + + -- * Dumping stuff + dumpIdInfoOfProgram + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Core +import PrelNames ( makeStaticName ) +import GHC.Core.Ppr +import GHC.Core.FVs( exprFreeVars ) +import Var +import SrcLoc +import VarEnv +import VarSet +import Name +import Literal +import DataCon +import PrimOp +import Id +import IdInfo +import PrelNames( absentErrorIdKey ) +import Type +import Predicate +import TyCoRep( TyCoBinder(..), TyBinder ) +import Coercion +import TyCon +import Unique +import Outputable +import TysPrim +import GHC.Driver.Session +import FastString +import Maybes +import ListSetOps ( minusList ) +import BasicTypes ( Arity, isConLike ) +import Util +import Pair +import Data.ByteString ( ByteString ) +import Data.Function ( on ) +import Data.List +import Data.Ord ( comparing ) +import OrdList +import qualified Data.Set as Set +import UniqSet + +{- +************************************************************************ +* * +\subsection{Find the type of a Core atom/expression} +* * +************************************************************************ +-} + +exprType :: CoreExpr -> Type +-- ^ Recover the type of a well-typed Core expression. Fails when +-- applied to the actual 'GHC.Core.Type' expression as it cannot +-- really be said to have a type +exprType (Var var) = idType var +exprType (Lit lit) = literalType lit +exprType (Coercion co) = coercionType co +exprType (Let bind body) + | NonRec tv rhs <- bind -- See Note [Type bindings] + , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) + | otherwise = exprType body +exprType (Case _ _ ty _) = ty +exprType (Cast _ co) = pSnd (coercionKind co) +exprType (Tick _ e) = exprType e +exprType (Lam binder expr) = mkLamType binder (exprType expr) +exprType e@(App _ _) + = case collectArgs e of + (fun, args) -> applyTypeToArgs e (exprType fun) args + +exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy + +coreAltType :: CoreAlt -> Type +-- ^ Returns the type of the alternatives right hand side +coreAltType alt@(_,bs,rhs) + = case occCheckExpand bs rhs_ty of + -- Note [Existential variables and silly type synonyms] + Just ty -> ty + Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty) + where + rhs_ty = exprType rhs + +coreAltsType :: [CoreAlt] -> Type +-- ^ Returns the type of the first alternative, which should be the same as for all alternatives +coreAltsType (alt:_) = coreAltType alt +coreAltsType [] = panic "corAltsType" + +-- | Is this expression levity polymorphic? This should be the +-- same as saying (isKindLevPoly . typeKind . exprType) but +-- much faster. +isExprLevPoly :: CoreExpr -> Bool +isExprLevPoly = go + where + go (Var _) = False -- no levity-polymorphic binders + go (Lit _) = False -- no levity-polymorphic literals + go e@(App f _) | not (go_app f) = False + | otherwise = check_type e + go (Lam _ _) = False + go (Let _ e) = go e + go e@(Case {}) = check_type e -- checking type is fast + go e@(Cast {}) = check_type e + go (Tick _ e) = go e + go e@(Type {}) = pprPanic "isExprLevPoly ty" (ppr e) + go (Coercion {}) = False -- this case can happen in SetLevels + + check_type = isTypeLevPoly . exprType -- slow approach + + -- if the function is a variable (common case), check its + -- levityInfo. This might mean we don't need to look up and compute + -- on the type. Spec of these functions: return False if there is + -- no possibility, ever, of this expression becoming levity polymorphic, + -- no matter what it's applied to; return True otherwise. + -- returning True is always safe. See also Note [Levity info] in + -- IdInfo + go_app (Var id) = not (isNeverLevPolyId id) + go_app (Lit _) = False + go_app (App f _) = go_app f + go_app (Lam _ e) = go_app e + go_app (Let _ e) = go_app e + go_app (Case _ _ ty _) = resultIsLevPoly ty + go_app (Cast _ co) = resultIsLevPoly (coercionRKind co) + go_app (Tick _ e) = go_app e + go_app e@(Type {}) = pprPanic "isExprLevPoly app ty" (ppr e) + go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e) + + +{- +Note [Type bindings] +~~~~~~~~~~~~~~~~~~~~ +Core does allow type bindings, although such bindings are +not much used, except in the output of the desugarer. +Example: + let a = Int in (\x:a. x) +Given this, exprType must be careful to substitute 'a' in the +result type (#8522). + +Note [Existential variables and silly type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = forall a. T (Funny a) + type Funny a = Bool + f :: T -> Bool + f (T x) = x + +Now, the type of 'x' is (Funny a), where 'a' is existentially quantified. +That means that 'exprType' and 'coreAltsType' may give a result that *appears* +to mention an out-of-scope type variable. See #3409 for a more real-world +example. + +Various possibilities suggest themselves: + + - Ignore the problem, and make Lint not complain about such variables + + - Expand all type synonyms (or at least all those that discard arguments) + This is tricky, because at least for top-level things we want to + retain the type the user originally specified. + + - Expand synonyms on the fly, when the problem arises. That is what + we are doing here. It's not too expensive, I think. + +Note that there might be existentially quantified coercion variables, too. +-} + +-- Not defined with applyTypeToArg because you can't print from GHC.Core. +applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type +-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. +-- The first argument is just for debugging, and gives some context +applyTypeToArgs e op_ty args + = go op_ty args + where + go op_ty [] = op_ty + go op_ty (Type ty : args) = go_ty_args op_ty [ty] args + go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args + go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty + = go res_ty args + go _ _ = pprPanic "applyTypeToArgs" panic_msg + + -- go_ty_args: accumulate type arguments so we can + -- instantiate all at once with piResultTys + go_ty_args op_ty rev_tys (Type ty : args) + = go_ty_args op_ty (ty:rev_tys) args + go_ty_args op_ty rev_tys (Coercion co : args) + = go_ty_args op_ty (mkCoercionTy co : rev_tys) args + go_ty_args op_ty rev_tys args + = go (piResultTys op_ty (reverse rev_tys)) args + + panic_msg = vcat [ text "Expression:" <+> pprCoreExpr e + , text "Type:" <+> ppr op_ty + , text "Args:" <+> ppr args ] + + +{- +************************************************************************ +* * +\subsection{Attaching notes} +* * +************************************************************************ +-} + +-- | Wrap the given expression in the coercion safely, dropping +-- identity coercions and coalescing nested coercions +mkCast :: CoreExpr -> CoercionR -> CoreExpr +mkCast e co + | ASSERT2( coercionRole co == Representational + , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast") + <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) ) + isReflCo co + = e + +mkCast (Coercion e_co) co + | isCoVarType (coercionRKind co) + -- The guard here checks that g has a (~#) on both sides, + -- otherwise decomposeCo fails. Can in principle happen + -- with unsafeCoerce + = Coercion (mkCoCast e_co co) + +mkCast (Cast expr co2) co + = WARN(let { from_ty = coercionLKind co; + to_ty2 = coercionRKind co2 } in + not (from_ty `eqType` to_ty2), + vcat ([ text "expr:" <+> ppr expr + , text "co2:" <+> ppr co2 + , text "co:" <+> ppr co ]) ) + mkCast expr (mkTransCo co2 co) + +mkCast (Tick t expr) co + = Tick t (mkCast expr co) + +mkCast expr co + = let from_ty = coercionLKind co in + WARN( not (from_ty `eqType` exprType expr), + text "Trying to coerce" <+> text "(" <> ppr expr + $$ text "::" <+> ppr (exprType expr) <> text ")" + $$ ppr co $$ ppr (coercionType co) ) + (Cast expr co) + +-- | Wraps the given expression in the source annotation, dropping the +-- annotation if possible. +mkTick :: Tickish Id -> CoreExpr -> CoreExpr +mkTick t orig_expr = mkTick' id id orig_expr + where + -- Some ticks (cost-centres) can be split in two, with the + -- non-counting part having laxer placement properties. + canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + + mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through) + -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with) + -> CoreExpr -- ^ current expression + -> CoreExpr + mkTick' top rest expr = case expr of + + -- Cost centre ticks should never be reordered relative to each + -- other. Therefore we can stop whenever two collide. + Tick t2 e + | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr + + -- Otherwise we assume that ticks of different placements float + -- through each other. + | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e + + -- For annotations this is where we make sure to not introduce + -- redundant ticks. + | tickishContains t t2 -> mkTick' top rest e + | tickishContains t2 t -> orig_expr + | otherwise -> mkTick' top (rest . Tick t2) e + + -- Ticks don't care about types, so we just float all ticks + -- through them. Note that it's not enough to check for these + -- cases top-level. While mkTick will never produce Core with type + -- expressions below ticks, such constructs can be the result of + -- unfoldings. We therefore make an effort to put everything into + -- the right place no matter what we start with. + Cast e co -> mkTick' (top . flip Cast co) rest e + Coercion co -> Coercion co + + Lam x e + -- Always float through type lambdas. Even for non-type lambdas, + -- floating is allowed for all but the most strict placement rule. + | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime + -> mkTick' (top . Lam x) rest e + + -- If it is both counting and scoped, we split the tick into its + -- two components, often allowing us to keep the counting tick on + -- the outside of the lambda and push the scoped tick inside. + -- The point of this is that the counting tick can probably be + -- floated, and the lambda may then be in a position to be + -- beta-reduced. + | canSplit + -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + + App f arg + -- Always float through type applications. + | not (isRuntimeArg arg) + -> mkTick' (top . flip App arg) rest f + + -- We can also float through constructor applications, placement + -- permitting. Again we can split. + | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) + -> if tickishPlace t == PlaceCostCentre + then top $ rest $ tickHNFArgs t expr + else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + + Var x + | notFunction && tickishPlace t == PlaceCostCentre + -> orig_expr + | notFunction && canSplit + -> top $ Tick (mkNoScope t) $ rest expr + where + -- SCCs can be eliminated on variables provided the variable + -- is not a function. In these cases the SCC makes no difference: + -- the cost of evaluating the variable will be attributed to its + -- definition site. When the variable refers to a function, however, + -- an SCC annotation on the variable affects the cost-centre stack + -- when the function is called, so we must retain those. + notFunction = not (isFunTy (idType x)) + + Lit{} + | tickishPlace t == PlaceCostCentre + -> orig_expr + + -- Catch-all: Annotate where we stand + _any -> top $ Tick t $ rest expr + +mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr +mkTicks ticks expr = foldr mkTick expr ticks + +isSaturatedConApp :: CoreExpr -> Bool +isSaturatedConApp e = go e [] + where go (App f a) as = go f (a:as) + go (Var fun) args + = isConLikeId fun && idArity fun == valArgCount args + go (Cast f _) as = go f as + go _ _ = False + +mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr +mkTickNoHNF t e + | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e + +-- push a tick into the arguments of a HNF (call or constructor app) +tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr +tickHNFArgs t e = push t e + where + push t (App f (Type u)) = App (push t f) (Type u) + push t (App f arg) = App (push t f) (mkTick t arg) + push _t e = e + +-- | Strip ticks satisfying a predicate from top of an expression +stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b) +stripTicksTop p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts other = (reverse ts, other) + +-- | Strip ticks satisfying a predicate from top of an expression, +-- returning the remaining expression +stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b +stripTicksTopE p = go + where go (Tick t e) | p t = go e + go other = other + +-- | Strip ticks satisfying a predicate from top of an expression, +-- returning the ticks +stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] +stripTicksTopT p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts _ = ts + +-- | Completely strip ticks satisfying a predicate from an +-- expression. Note this is O(n) in the size of the expression! +stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b +stripTicksE p expr = go expr + where go (App e a) = App (go e) (go a) + go (Lam b e) = Lam b (go e) + go (Let b e) = Let (go_bs b) (go e) + go (Case e b t as) = Case (go e) b t (map go_a as) + go (Cast e c) = Cast (go e) c + go (Tick t e) + | p t = go e + | otherwise = Tick t (go e) + go other = other + go_bs (NonRec b e) = NonRec b (go e) + go_bs (Rec bs) = Rec (map go_b bs) + go_b (b, e) = (b, go e) + go_a (c,bs,e) = (c,bs, go e) + +stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] +stripTicksT p expr = fromOL $ go expr + where go (App e a) = go e `appOL` go a + go (Lam _ e) = go e + go (Let b e) = go_bs b `appOL` go e + go (Case e _ _ as) = go e `appOL` concatOL (map go_a as) + go (Cast e _) = go e + go (Tick t e) + | p t = t `consOL` go e + | otherwise = go e + go _ = nilOL + go_bs (NonRec _ e) = go e + go_bs (Rec bs) = concatOL (map go_b bs) + go_b (_, e) = go e + go_a (_, _, e) = go e + +{- +************************************************************************ +* * +\subsection{Other expression construction} +* * +************************************************************************ +-} + +bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr +-- ^ @bindNonRec x r b@ produces either: +-- +-- > let x = r in b +-- +-- or: +-- +-- > case r of x { _DEFAULT_ -> b } +-- +-- depending on whether we have to use a @case@ or @let@ +-- binding for the expression (see 'needsCaseBinding'). +-- It's used by the desugarer to avoid building bindings +-- that give Core Lint a heart attack, although actually +-- the simplifier deals with them perfectly well. See +-- also 'GHC.Core.Make.mkCoreLet' +bindNonRec bndr rhs body + | isTyVar bndr = let_bind + | isCoVar bndr = if isCoArg rhs then let_bind + {- See Note [Binding coercions] -} else case_bind + | isJoinId bndr = let_bind + | needsCaseBinding (idType bndr) rhs = case_bind + | otherwise = let_bind + where + case_bind = mkDefaultCase rhs bndr body + let_bind = Let (NonRec bndr rhs) body + +-- | Tests whether we have to use a @case@ rather than @let@ binding for this expression +-- as per the invariants of 'CoreExpr': see "GHC.Core#let_app_invariant" +needsCaseBinding :: Type -> CoreExpr -> Bool +needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs) + -- Make a case expression instead of a let + -- These can arise either from the desugarer, + -- or from beta reductions: (\x.e) (x +# y) + +mkAltExpr :: AltCon -- ^ Case alternative constructor + -> [CoreBndr] -- ^ Things bound by the pattern match + -> [Type] -- ^ The type arguments to the case alternative + -> CoreExpr +-- ^ This guy constructs the value that the scrutinee must have +-- given that you are in one particular branch of a case +mkAltExpr (DataAlt con) args inst_tys + = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) +mkAltExpr (LitAlt lit) [] [] + = Lit lit +mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" +mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" + +mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr +-- Make (case x of y { DEFAULT -> e } +mkDefaultCase scrut case_bndr body + = Case scrut case_bndr (exprType body) [(DEFAULT, [], body)] + +mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr +-- Use this function if possible, when building a case, +-- because it ensures that the type on the Case itself +-- doesn't mention variables bound by the case +-- See Note [Care with the type of a case expression] +mkSingleAltCase scrut case_bndr con bndrs body + = Case scrut case_bndr case_ty [(con,bndrs,body)] + where + body_ty = exprType body + + case_ty -- See Note [Care with the type of a case expression] + | Just body_ty' <- occCheckExpand bndrs body_ty + = body_ty' + + | otherwise + = pprPanic "mkSingleAltCase" (ppr scrut $$ ppr bndrs $$ ppr body_ty) + +{- Note [Care with the type of a case expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a phantom type synonym + type S a = Int +and we want to form the case expression + case x of K (a::*) -> (e :: S a) + +We must not make the type field of the case-expression (S a) because +'a' isn't in scope. Hence the call to occCheckExpand. This caused +issue #17056. + +NB: this situation can only arise with type synonyms, which can +falsely "mention" type variables that aren't "really there", and which +can be eliminated by expanding the synonym. + +Note [Binding coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider binding a CoVar, c = e. Then, we must satisfy +Note [Core type and coercion invariant] in GHC.Core, +which allows only (Coercion co) on the RHS. + +************************************************************************ +* * + Operations oer case alternatives +* * +************************************************************************ + +The default alternative must be first, if it exists at all. +This makes it easy to find, though it makes matching marginally harder. +-} + +-- | Extract the default case alternative +findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b) +findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) +findDefault alts = (alts, Nothing) + +addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)] +addDefault alts Nothing = alts +addDefault alts (Just rhs) = (DEFAULT, [], rhs) : alts + +isDefaultAlt :: (AltCon, a, b) -> Bool +isDefaultAlt (DEFAULT, _, _) = True +isDefaultAlt _ = False + +-- | Find the case alternative corresponding to a particular +-- constructor: panics if no such constructor exists +findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) + -- A "Nothing" result *is* legitimate + -- See Note [Unreachable code] +findAlt con alts + = case alts of + (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt) + _ -> go alts Nothing + where + go [] deflt = deflt + go (alt@(con1,_,_) : alts) deflt + = case con `cmpAltCon` con1 of + LT -> deflt -- Missed it already; the alts are in increasing order + EQ -> Just alt + GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt + +{- Note [Unreachable code] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible (although unusual) for GHC to find a case expression +that cannot match. For example: + + data Col = Red | Green | Blue + x = Red + f v = case x of + Red -> ... + _ -> ...(case x of { Green -> e1; Blue -> e2 })... + +Suppose that for some silly reason, x isn't substituted in the case +expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff +gets in the way; cf #3118.) Then the full-laziness pass might produce +this + + x = Red + lvl = case x of { Green -> e1; Blue -> e2 }) + f v = case x of + Red -> ... + _ -> ...lvl... + +Now if x gets inlined, we won't be able to find a matching alternative +for 'Red'. That's because 'lvl' is unreachable. So rather than crashing +we generate (error "Inaccessible alternative"). + +Similar things can happen (augmented by GADTs) when the Simplifier +filters down the matching alternatives in Simplify.rebuildCase. +-} + +--------------------------------- +mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)] +-- ^ Merge alternatives preserving order; alternatives in +-- the first argument shadow ones in the second +mergeAlts [] as2 = as2 +mergeAlts as1 [] = as1 +mergeAlts (a1:as1) (a2:as2) + = case a1 `cmpAlt` a2 of + LT -> a1 : mergeAlts as1 (a2:as2) + EQ -> a1 : mergeAlts as1 as2 -- Discard a2 + GT -> a2 : mergeAlts (a1:as1) as2 + + +--------------------------------- +trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] +-- ^ Given: +-- +-- > case (C a b x y) of +-- > C b x y -> ... +-- +-- We want to drop the leading type argument of the scrutinee +-- leaving the arguments to match against the pattern + +trimConArgs DEFAULT args = ASSERT( null args ) [] +trimConArgs (LitAlt _) args = ASSERT( null args ) [] +trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args + +filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities) + -> [Type] -- ^ And its type arguments + -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee + -> [(AltCon, [Var], a)] -- ^ Alternatives + -> ([AltCon], [(AltCon, [Var], a)]) + -- Returns: + -- 1. Constructors that will never be encountered by the + -- *default* case (if any). A superset of imposs_cons + -- 2. The new alternatives, trimmed by + -- a) remove imposs_cons + -- b) remove constructors which can't match because of GADTs + -- + -- NB: the final list of alternatives may be empty: + -- This is a tricky corner case. If the data type has no constructors, + -- which GHC allows, or if the imposs_cons covers all constructors (after taking + -- account of GADTs), then no alternatives can match. + -- + -- If callers need to preserve the invariant that there is always at least one branch + -- in a "case" statement then they will need to manually add a dummy case branch that just + -- calls "error" or similar. +filterAlts _tycon inst_tys imposs_cons alts + = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) + where + (alts_wo_default, maybe_deflt) = findDefault alts + alt_cons = [con | (con,_,_) <- alts_wo_default] + + trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default + + imposs_cons_set = Set.fromList imposs_cons + imposs_deflt_cons = + imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons + -- "imposs_deflt_cons" are handled + -- EITHER by the context, + -- OR by a non-DEFAULT branch in this case expression. + + impossible_alt :: [Type] -> (AltCon, a, b) -> Bool + impossible_alt _ (con, _, _) | con `Set.member` imposs_cons_set = True + impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con + impossible_alt _ _ = False + +-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. +-- See Note [Refine Default Alts] +refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders + -> TyCon -- ^ Type constructor of scrutinee's type + -> [Type] -- ^ Type arguments of scrutinee's type + -> [AltCon] -- ^ Constructors that cannot match the DEFAULT (if any) + -> [CoreAlt] + -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' +refineDefaultAlt us tycon tys imposs_deflt_cons all_alts + | (DEFAULT,_,rhs) : rest_alts <- all_alts + , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. + , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: + -- case x of { DEFAULT -> e } + -- and we don't want to fill in a default for them! + , Just all_cons <- tyConDataCons_maybe tycon + , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons] + -- We now know it's a data type, so we can use + -- UniqSet rather than Set (more efficient) + impossible con = con `elementOfUniqSet` imposs_data_cons + || dataConCannotMatch tys con + = case filterOut impossible all_cons of + -- Eliminate the default alternative + -- altogether if it can't match: + [] -> (False, rest_alts) + + -- It matches exactly one constructor, so fill it in: + [con] -> (True, mergeAlts rest_alts [(DataAlt con, ex_tvs ++ arg_ids, rhs)]) + -- We need the mergeAlts to keep the alternatives in the right order + where + (ex_tvs, arg_ids) = dataConRepInstPat us con tys + + -- It matches more than one, so do nothing + _ -> (False, all_alts) + + | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon) + , not (isFamilyTyCon tycon || isAbstractTyCon tycon) + -- Check for no data constructors + -- This can legitimately happen for abstract types and type families, + -- so don't report that + = (False, all_alts) + + | otherwise -- The common case + = (False, all_alts) + +{- Note [Refine Default Alts] + +refineDefaultAlt replaces the DEFAULT alt with a constructor if there is one +possible value it could be. + +The simplest example being + +foo :: () -> () +foo x = case x of !_ -> () + +rewrites to + +foo :: () -> () +foo x = case x of () -> () + +There are two reasons in general why this is desirable. + +1. We can simplify inner expressions + +In this example we can eliminate the inner case by refining the outer case. +If we don't refine it, we are left with both case expressions. + +``` +{-# LANGUAGE BangPatterns #-} +module Test where + +mid x = x +{-# NOINLINE mid #-} + +data Foo = Foo1 () + +test :: Foo -> () +test x = + case x of + !_ -> mid (case x of + Foo1 x1 -> x1) + +``` + +refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then x +becomes bound to `Foo ip1` so is inlined into the other case which +causes the KnownBranch optimisation to kick in. + + +2. combineIdenticalAlts does a better job + +Simon Jakobi also points out that that combineIdenticalAlts will do a better job +if we refine the DEFAULT first. + +``` +data D = C0 | C1 | C2 + +case e of + DEFAULT -> e0 + C0 -> e1 + C1 -> e1 +``` + +When we apply combineIdenticalAlts to this expression, it can't +combine the alts for C0 and C1, as we already have a default case. + +If we apply refineDefaultAlt first, we get + +``` +case e of + C0 -> e1 + C1 -> e1 + C2 -> e0 +``` + +and combineIdenticalAlts can turn that into + +``` +case e of + DEFAULT -> e1 + C2 -> e0 +``` + +It isn't obvious that refineDefaultAlt does this but if you look at its one +call site in SimplUtils then the `imposs_deflt_cons` argument is populated with +constructors which are matched elsewhere. + +-} + + + + +{- Note [Combine identical alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If several alternatives are identical, merge them into a single +DEFAULT alternative. I've occasionally seen this making a big +difference: + + case e of =====> case e of + C _ -> f x D v -> ....v.... + D v -> ....v.... DEFAULT -> f x + DEFAULT -> f x + +The point is that we merge common RHSs, at least for the DEFAULT case. +[One could do something more elaborate but I've never seen it needed.] +To avoid an expensive test, we just merge branches equal to the *first* +alternative; this picks up the common cases + a) all branches equal + b) some branches equal to the DEFAULT (which occurs first) + +The case where Combine Identical Alternatives transformation showed up +was like this (base/Foreign/C/Err/Error.hs): + + x | p `is` 1 -> e1 + | p `is` 2 -> e2 + ...etc... + +where @is@ was something like + + p `is` n = p /= (-1) && p == n + +This gave rise to a horrible sequence of cases + + case p of + (-1) -> $j p + 1 -> e1 + DEFAULT -> $j p + +and similarly in cascade for all the join points! + +NB: it's important that all this is done in [InAlt], *before* we work +on the alternatives themselves, because Simplify.simplAlt may zap the +occurrence info on the binders in the alternatives, which in turn +defeats combineIdenticalAlts (see #7360). + +Note [Care with impossible-constructors when combining alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (#10538) + data T = A | B | C | D + + case x::T of (Imposs-default-cons {A,B}) + DEFAULT -> e1 + A -> e2 + B -> e1 + +When calling combineIdentialAlts, we'll have computed that the +"impossible constructors" for the DEFAULT alt is {A,B}, since if x is +A or B we'll take the other alternatives. But suppose we combine B +into the DEFAULT, to get + + case x::T of (Imposs-default-cons {A}) + DEFAULT -> e1 + A -> e2 + +Then we must be careful to trim the impossible constructors to just {A}, +else we risk compiling 'e1' wrong! + +Not only that, but we take care when there is no DEFAULT beforehand, +because we are introducing one. Consider + + case x of (Imposs-default-cons {A,B,C}) + A -> e1 + B -> e2 + C -> e1 + +Then when combining the A and C alternatives we get + + case x of (Imposs-default-cons {B}) + DEFAULT -> e1 + B -> e2 + +Note that we have a new DEFAULT branch that we didn't have before. So +we need delete from the "impossible-default-constructors" all the +known-con alternatives that we have eliminated. (In #11172 we +missed the first one.) + +-} + +combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT + -> [CoreAlt] + -> (Bool, -- True <=> something happened + [AltCon], -- New constructors that cannot match DEFAULT + [CoreAlt]) -- New alternatives +-- See Note [Combine identical alternatives] +-- True <=> we did some combining, result is a single DEFAULT alternative +combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts) + | all isDeadBinder bndrs1 -- Remember the default + , not (null elim_rest) -- alternative comes first + = (True, imposs_deflt_cons', deflt_alt : filtered_rest) + where + (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts + deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1) + + -- See Note [Care with impossible-constructors when combining alternatives] + imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons + elim_cons = elim_con1 ++ map fstOf3 elim_rest + elim_con1 = case con1 of -- Don't forget con1! + DEFAULT -> [] -- See Note [ + _ -> [con1] + + cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 + identical_to_alt1 (_con,bndrs,rhs) + = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 + tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest + +combineIdenticalAlts imposs_cons alts + = (False, imposs_cons, alts) + +{- ********************************************************************* +* * + exprIsTrivial +* * +************************************************************************ + +Note [exprIsTrivial] +~~~~~~~~~~~~~~~~~~~~ +@exprIsTrivial@ is true of expressions we are unconditionally happy to + duplicate; simple variables and constants, and type + applications. Note that primop Ids aren't considered + trivial unless + +Note [Variables are trivial] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There used to be a gruesome test for (hasNoBinding v) in the +Var case: + exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 +The idea here is that a constructor worker, like \$wJust, is +really short for (\x -> \$wJust x), because \$wJust has no binding. +So it should be treated like a lambda. Ditto unsaturated primops. +But now constructor workers are not "have-no-binding" Ids. And +completely un-applied primops and foreign-call Ids are sufficiently +rare that I plan to allow them to be duplicated and put up with +saturating them. + +Note [Tick trivial] +~~~~~~~~~~~~~~~~~~~ +Ticks are only trivial if they are pure annotations. If we treat +"tick<n> x" as trivial, it will be inlined inside lambdas and the +entry count will be skewed, for example. Furthermore "scc<n> x" will +turn into just "x" in mkTick. + +Note [Empty case is trivial] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The expression (case (x::Int) Bool of {}) is just a type-changing +case used when we are sure that 'x' will not return. See +Note [Empty case alternatives] in GHC.Core. + +If the scrutinee is trivial, then so is the whole expression; and the +CoreToSTG pass in fact drops the case expression leaving only the +scrutinee. + +Having more trivial expressions is good. Moreover, if we don't treat +it as trivial we may land up with let-bindings like + let v = case x of {} in ... +and after CoreToSTG that gives + let v = x in ... +and that confuses the code generator (#11155). So best to kill +it off at source. +-} + +exprIsTrivial :: CoreExpr -> Bool +-- If you modify this function, you may also +-- need to modify getIdFromTrivialExpr +exprIsTrivial (Var _) = True -- See Note [Variables are trivial] +exprIsTrivial (Type _) = True +exprIsTrivial (Coercion _) = True +exprIsTrivial (Lit lit) = litIsTrivial lit +exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e +exprIsTrivial (Lam b e) = not (isRuntimeVar b) && exprIsTrivial e +exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e + -- See Note [Tick trivial] +exprIsTrivial (Cast e _) = exprIsTrivial e +exprIsTrivial (Case e _ _ []) = exprIsTrivial e -- See Note [Empty case is trivial] +exprIsTrivial _ = False + +{- +Note [getIdFromTrivialExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When substituting in a breakpoint we need to strip away the type cruft +from a trivial expression and get back to the Id. The invariant is +that the expression we're substituting was originally trivial +according to exprIsTrivial, AND the expression is not a literal. +See Note [substTickish] for how breakpoint substitution preserves +this extra invariant. + +We also need this functionality in CorePrep to extract out Id of a +function which we are saturating. However, in this case we don't know +if the variable actually refers to a literal; thus we use +'getIdFromTrivialExpr_maybe' to handle this case. See test +T12076lit for an example where this matters. +-} + +getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id +getIdFromTrivialExpr e + = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e)) + (getIdFromTrivialExpr_maybe e) + +getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id +-- See Note [getIdFromTrivialExpr] +-- Th equations for this should line up with those for exprIsTrivial +getIdFromTrivialExpr_maybe e + = go e + where + go (App f t) | not (isRuntimeArg t) = go f + go (Tick t e) | not (tickishIsCode t) = go e + go (Cast e _) = go e + go (Lam b e) | not (isRuntimeVar b) = go e + go (Case e _ _ []) = go e + go (Var v) = Just v + go _ = Nothing + +{- +exprIsBottom is a very cheap and cheerful function; it may return +False for bottoming expressions, but it never costs much to ask. See +also GHC.Core.Arity.exprBotStrictness_maybe, but that's a bit more +expensive. +-} + +exprIsBottom :: CoreExpr -> Bool +-- See Note [Bottoming expressions] +exprIsBottom e + | isEmptyTy (exprType e) + = True + | otherwise + = go 0 e + where + go n (Var v) = isBottomingId v && n >= idArity v + go n (App e a) | isTypeArg a = go n e + | otherwise = go (n+1) e + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (Let _ e) = go n e + go n (Lam v e) | isTyVar v = go n e + go _ (Case _ _ _ alts) = null alts + -- See Note [Empty case alternatives] in GHC.Core + go _ _ = 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 exprIsBottom +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. + + +************************************************************************ +* * + exprIsDupable +* * +************************************************************************ + +Note [exprIsDupable] +~~~~~~~~~~~~~~~~~~~~ +@exprIsDupable@ is true of expressions that can be duplicated at a modest + cost in code size. This will only happen in different case + branches, so there's no issue about duplicating work. + + That is, exprIsDupable returns True of (f x) even if + f is very very expensive to call. + + Its only purpose is to avoid fruitless let-binding + and then inlining of case join points +-} + +exprIsDupable :: DynFlags -> CoreExpr -> Bool +exprIsDupable dflags e + = isJust (go dupAppSize e) + where + go :: Int -> CoreExpr -> Maybe Int + go n (Type {}) = Just n + go n (Coercion {}) = Just n + go n (Var {}) = decrement n + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (App f a) | Just n' <- go n a = go n' f + go n (Lit lit) | litIsDupable dflags lit = decrement n + go _ _ = Nothing + + decrement :: Int -> Maybe Int + decrement 0 = Nothing + decrement n = Just (n-1) + +dupAppSize :: Int +dupAppSize = 8 -- Size of term we are prepared to duplicate + -- This is *just* big enough to make test MethSharing + -- inline enough join points. Really it should be + -- smaller, and could be if we fixed #4960. + +{- +************************************************************************ +* * + exprIsCheap, exprIsExpandable +* * +************************************************************************ + +Note [exprIsWorkFree] +~~~~~~~~~~~~~~~~~~~~~ +exprIsWorkFree is used when deciding whether to inline something; we +don't inline it if doing so might duplicate work, by peeling off a +complete copy of the expression. Here we do not want even to +duplicate a primop (#5623): + eg let x = a #+ b in x +# x + we do not want to inline/duplicate x + +Previously we were a bit more liberal, which led to the primop-duplicating +problem. However, being more conservative did lead to a big regression in +one nofib benchmark, wheel-sieve1. The situation looks like this: + + let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool + noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> + case GHC.Prim.<=# x_aRs 2 of _ { + GHC.Types.False -> notDivBy ps_adM qs_adN; + GHC.Types.True -> lvl_r2Eb }} + go = \x. ...(noFactor (I# y))....(go x')... + +The function 'noFactor' is heap-allocated and then called. Turns out +that 'notDivBy' is strict in its THIRD arg, but that is invisible to +the caller of noFactor, which therefore cannot do w/w and +heap-allocates noFactor's argument. At the moment (May 12) we are just +going to put up with this, because the previous more aggressive inlining +(which treated 'noFactor' as work-free) was duplicating primops, which +in turn was making inner loops of array calculations runs slow (#5623) + +Note [Case expressions are work-free] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Are case-expressions work-free? Consider + let v = case x of (p,q) -> p + go = \y -> ...case v of ... +Should we inline 'v' at its use site inside the loop? At the moment +we do. I experimented with saying that case are *not* work-free, but +that increased allocation slightly. It's a fairly small effect, and at +the moment we go for the slightly more aggressive version which treats +(case x of ....) as work-free if the alternatives are. + +Moreover it improves arities of overloaded functions where +there is only dictionary selection (no construction) involved + +Note [exprIsCheap] +~~~~~~~~~~~~~~~~~~ + +See also Note [Interaction of exprIsCheap and lone variables] in GHC.Core.Unfold + +@exprIsCheap@ looks at a Core expression and returns \tr{True} if +it is obviously in weak head normal form, or is cheap to get to WHNF. +[Note that that's not the same as exprIsDupable; an expression might be +big, and hence not dupable, but still cheap.] + +By ``cheap'' we mean a computation we're willing to: + push inside a lambda, or + inline at more than one place +That might mean it gets evaluated more than once, instead of being +shared. The main examples of things which aren't WHNF but are +``cheap'' are: + + * case e of + pi -> ei + (where e, and all the ei are cheap) + + * let x = e in b + (where e and b are cheap) + + * op x1 ... xn + (where op is a cheap primitive operator) + + * error "foo" + (because we are happy to substitute it inside a lambda) + +Notice that a variable is considered 'cheap': we can push it inside a lambda, +because sharing will make sure it is only evaluated once. + +Note [exprIsCheap and exprIsHNF] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that exprIsHNF does not imply exprIsCheap. Eg + let x = fac 20 in Just x +This responds True to exprIsHNF (you can discard a seq), but +False to exprIsCheap. + +Note [Arguments and let-bindings exprIsCheapX] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What predicate should we apply to the argument of an application, or the +RHS of a let-binding? + +We used to say "exprIsTrivial arg" due to concerns about duplicating +nested constructor applications, but see #4978. So now we just recursively +use exprIsCheapX. + +We definitely want to treat let and app the same. The principle here is +that + let x = blah in f x +should behave equivalently to + f blah + +This in turn means that the 'letrec g' does not prevent eta expansion +in this (which it previously was): + f = \x. let v = case x of + True -> letrec g = \w. blah + in g + False -> \x. x + in \w. v True +-} + +-------------------- +exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] +exprIsWorkFree = exprIsCheapX isWorkFreeApp + +exprIsCheap :: CoreExpr -> Bool +exprIsCheap = exprIsCheapX isCheapApp + +exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool +exprIsCheapX ok_app e + = ok e + where + ok e = go 0 e + + -- n is the number of value arguments + go n (Var v) = ok_app v n + go _ (Lit {}) = True + go _ (Type {}) = True + go _ (Coercion {}) = True + go n (Cast e _) = go n e + go n (Case scrut _ _ alts) = ok scrut && + and [ go n rhs | (_,_,rhs) <- alts ] + go n (Tick t e) | tickishCounts t = False + | otherwise = go n e + go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e + | otherwise = go n e + go n (App f e) | isRuntimeArg e = go (n+1) f && ok e + | otherwise = go n f + go n (Let (NonRec _ r) e) = go n e && ok r + go n (Let (Rec prs) e) = go n e && all (ok . snd) prs + + -- Case: see Note [Case expressions are work-free] + -- App, Let: see Note [Arguments and let-bindings exprIsCheapX] + + +{- Note [exprIsExpandable] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +An expression is "expandable" if we are willing to duplicate it, if doing +so might make a RULE or case-of-constructor fire. Consider + let x = (a,b) + y = build g + in ....(case x of (p,q) -> rhs)....(foldr k z y).... + +We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold), +but we do want + + * the case-expression to simplify + (via exprIsConApp_maybe, exprIsLiteral_maybe) + + * the foldr/build RULE to fire + (by expanding the unfolding during rule matching) + +So we classify the unfolding of a let-binding as "expandable" (via the +uf_expandable field) if we want to do this kind of on-the-fly +expansion. Specifically: + +* True of constructor applications (K a b) + +* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in BasicTypes. + (NB: exprIsCheap might not be true of this) + +* False of case-expressions. If we have + let x = case ... in ...(case x of ...)... + we won't simplify. We have to inline x. See #14688. + +* False of let-expressions (same reason); and in any case we + float lets out of an RHS if doing so will reveal an expandable + application (see SimplEnv.doFloatFromRhs). + +* Take care: exprIsExpandable should /not/ be true of primops. I + found this in test T5623a: + let q = /\a. Ptr a (a +# b) + in case q @ Float of Ptr v -> ...q... + + q's inlining should not be expandable, else exprIsConApp_maybe will + say that (q @ Float) expands to (Ptr a (a +# b)), and that will + duplicate the (a +# b) primop, which we should not do lightly. + (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) +-} + +------------------------------------- +exprIsExpandable :: CoreExpr -> Bool +-- See Note [exprIsExpandable] +exprIsExpandable e + = ok e + where + ok e = go 0 e + + -- n is the number of value arguments + go n (Var v) = isExpandableApp v n + go _ (Lit {}) = True + go _ (Type {}) = True + go _ (Coercion {}) = True + go n (Cast e _) = go n e + go n (Tick t e) | tickishCounts t = False + | otherwise = go n e + go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e + | otherwise = go n e + go n (App f e) | isRuntimeArg e = go (n+1) f && ok e + | otherwise = go n f + go _ (Case {}) = False + go _ (Let {}) = False + + +------------------------------------- +type CheapAppFun = Id -> Arity -> Bool + -- Is an application of this function to n *value* args + -- always cheap, assuming the arguments are cheap? + -- True mainly of data constructors, partial applications; + -- but with minor variations: + -- isWorkFreeApp + -- isCheapApp + -- isExpandableApp + +isWorkFreeApp :: CheapAppFun +isWorkFreeApp fn n_val_args + | n_val_args == 0 -- No value args + = True + | n_val_args < idArity fn -- Partial application + = True + | otherwise + = case idDetails fn of + DataConWorkId {} -> True + _ -> False + +isCheapApp :: CheapAppFun +isCheapApp fn n_val_args + | isWorkFreeApp fn n_val_args = True + | isBottomingId fn = True -- See Note [isCheapApp: bottoming functions] + | otherwise + = case idDetails fn of + DataConWorkId {} -> True -- Actually handled by isWorkFreeApp + RecSelId {} -> n_val_args == 1 -- See Note [Record selection] + ClassOpId {} -> n_val_args == 1 + PrimOpId op -> primOpIsCheap op + _ -> False + -- In principle we should worry about primops + -- that return a type variable, since the result + -- might be applied to something, but I'm not going + -- to bother to check the number of args + +isExpandableApp :: CheapAppFun +isExpandableApp fn n_val_args + | isWorkFreeApp fn n_val_args = True + | otherwise + = case idDetails fn of + DataConWorkId {} -> True -- Actually handled by isWorkFreeApp + RecSelId {} -> n_val_args == 1 -- See Note [Record selection] + ClassOpId {} -> n_val_args == 1 + PrimOpId {} -> False + _ | isBottomingId fn -> False + -- See Note [isExpandableApp: bottoming functions] + | isConLike (idRuleMatchInfo fn) -> True + | all_args_are_preds -> True + | otherwise -> False + + where + -- See if all the arguments are PredTys (implicit params or classes) + -- If so we'll regard it as expandable; see Note [Expandable overloadings] + all_args_are_preds = all_pred_args n_val_args (idType fn) + + all_pred_args n_val_args ty + | n_val_args == 0 + = True + + | Just (bndr, ty) <- splitPiTy_maybe ty + = case bndr of + Named {} -> all_pred_args n_val_args ty + Anon InvisArg _ -> all_pred_args (n_val_args-1) ty + Anon VisArg _ -> False + + | otherwise + = False + +{- Note [isCheapApp: bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I'm not sure why we have a special case for bottoming +functions in isCheapApp. Maybe we don't need it. + +Note [isExpandableApp: bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important that isExpandableApp does not respond True to bottoming +functions. Recall undefined :: HasCallStack => a +Suppose isExpandableApp responded True to (undefined d), and we had: + + x = undefined <dict-expr> + +Then Simplify.prepareRhs would ANF the RHS: + + d = <dict-expr> + x = undefined d + +This is already bad: we gain nothing from having x bound to (undefined +var), unlike the case for data constructors. Worse, we get the +simplifier loop described in OccurAnal Note [Cascading inlines]. +Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will +certainly_inline; so we end up inlining d right back into x; but in +the end x doesn't inline because it is bottom (preInlineUnconditionally); +so the process repeats.. We could elaborate the certainly_inline logic +some more, but it's better just to treat bottoming bindings as +non-expandable, because ANFing them is a bad idea in the first place. + +Note [Record selection] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +I'm experimenting with making record selection +look cheap, so we will substitute it inside a +lambda. Particularly for dictionary field selection. + +BUT: Take care with (sel d x)! The (sel d) might be cheap, but +there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) + +Note [Expandable overloadings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose the user wrote this + {-# RULE forall x. foo (negate x) = h x #-} + f x = ....(foo (negate x)).... +He'd expect the rule to fire. But since negate is overloaded, we might +get this: + f = \d -> let n = negate d in \x -> ...foo (n x)... +So we treat the application of a function (negate in this case) to a +*dictionary* as expandable. In effect, every function is CONLIKE when +it's applied only to dictionaries. + + +************************************************************************ +* * + exprOkForSpeculation +* * +************************************************************************ +-} + +----------------------------- +-- | 'exprOkForSpeculation' returns True of an expression that is: +-- +-- * Safe to evaluate even if normal order eval might not +-- evaluate the expression at all, or +-- +-- * Safe /not/ to evaluate even if normal order would do so +-- +-- It is usually called on arguments of unlifted type, but not always +-- In particular, Simplify.rebuildCase calls it on lifted types +-- when a 'case' is a plain 'seq'. See the example in +-- Note [exprOkForSpeculation: case expressions] below +-- +-- Precisely, it returns @True@ iff: +-- a) The expression guarantees to terminate, +-- b) soon, +-- c) without causing a write side effect (e.g. writing a mutable variable) +-- d) without throwing a Haskell exception +-- e) without risking an unchecked runtime exception (array out of bounds, +-- divide by zero) +-- +-- For @exprOkForSideEffects@ the list is the same, but omitting (e). +-- +-- Note that +-- exprIsHNF implies exprOkForSpeculation +-- exprOkForSpeculation implies exprOkForSideEffects +-- +-- See Note [PrimOp can_fail and has_side_effects] in PrimOp +-- and Note [Transformations affected by can_fail and has_side_effects] +-- +-- As an example of the considerations in this test, consider: +-- +-- > let x = case y# +# 1# of { r# -> I# r# } +-- > in E +-- +-- being translated to: +-- +-- > case y# +# 1# of { r# -> +-- > let x = I# r# +-- > in E +-- > } +-- +-- We can only do this if the @y + 1@ is ok for speculation: it has no +-- side effects, and can't diverge or raise an exception. + +exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool +exprOkForSpeculation = expr_ok primOpOkForSpeculation +exprOkForSideEffects = expr_ok primOpOkForSideEffects + +expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool +expr_ok _ (Lit _) = True +expr_ok _ (Type _) = True +expr_ok _ (Coercion _) = True + +expr_ok primop_ok (Var v) = app_ok primop_ok v [] +expr_ok primop_ok (Cast e _) = expr_ok primop_ok e +expr_ok primop_ok (Lam b e) + | isTyVar b = expr_ok primop_ok e + | otherwise = True + +-- Tick annotations that *tick* cannot be speculated, because these +-- are meant to identify whether or not (and how often) the particular +-- source expression was evaluated at runtime. +expr_ok primop_ok (Tick tickish e) + | tickishCounts tickish = False + | otherwise = expr_ok primop_ok e + +expr_ok _ (Let {}) = False + -- Lets can be stacked deeply, so just give up. + -- In any case, the argument of exprOkForSpeculation is + -- usually in a strict context, so any lets will have been + -- floated away. + +expr_ok primop_ok (Case scrut bndr _ alts) + = -- See Note [exprOkForSpeculation: case expressions] + expr_ok primop_ok scrut + && isUnliftedType (idType bndr) + && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts + && altsAreExhaustive alts + +expr_ok primop_ok other_expr + | (expr, args) <- collectArgs other_expr + = case stripTicksTopE (not . tickishCounts) expr of + Var f -> app_ok primop_ok f args + -- 'LitRubbish' is the only literal that can occur in the head of an + -- application and will not be matched by the above case (Var /= Lit). + Lit lit -> ASSERT( lit == rubbishLit ) True + _ -> False + +----------------------------- +app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool +app_ok primop_ok fun args + = case idDetails fun of + DFunId new_type -> not new_type + -- DFuns terminate, unless the dict is implemented + -- with a newtype in which case they may not + + DataConWorkId {} -> True + -- The strictness of the constructor has already + -- been expressed by its "wrapper", so we don't need + -- to take the arguments into account + + PrimOpId op + | isDivOp op + , [arg1, Lit lit] <- args + -> not (isZeroLit lit) && expr_ok primop_ok arg1 + -- Special case for dividing operations that fail + -- In general they are NOT ok-for-speculation + -- (which primop_ok will catch), but they ARE OK + -- if the divisor is definitely non-zero. + -- Often there is a literal divisor, and this + -- can get rid of a thunk in an inner loop + + | SeqOp <- op -- See Note [exprOkForSpeculation and SeqOp/DataToTagOp] + -> False -- for the special cases for SeqOp and DataToTagOp + | DataToTagOp <- op + -> False + + | otherwise + -> primop_ok op -- Check the primop itself + && and (zipWith primop_arg_ok arg_tys args) -- Check the arguments + + _other -> isUnliftedType (idType fun) -- c.f. the Var case of exprIsHNF + || idArity fun > n_val_args -- Partial apps + -- NB: even in the nullary case, do /not/ check + -- for evaluated-ness of the fun; + -- see Note [exprOkForSpeculation and evaluated variables] + where + n_val_args = valArgCount args + where + (arg_tys, _) = splitPiTys (idType fun) + + primop_arg_ok :: TyBinder -> CoreExpr -> Bool + primop_arg_ok (Named _) _ = True -- A type argument + primop_arg_ok (Anon _ ty) arg -- A term argument + | isUnliftedType ty = expr_ok primop_ok arg + | otherwise = True -- See Note [Primops with lifted arguments] + +----------------------------- +altsAreExhaustive :: [Alt b] -> Bool +-- True <=> the case alternatives are definitely exhaustive +-- False <=> they may or may not be +altsAreExhaustive [] + = False -- Should not happen +altsAreExhaustive ((con1,_,_) : alts) + = case con1 of + DEFAULT -> True + LitAlt {} -> False + DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1) + -- It is possible to have an exhaustive case that does not + -- enumerate all constructors, notably in a GADT match, but + -- we behave conservatively here -- I don't think it's important + -- enough to deserve special treatment + +-- | True of dyadic operators that can fail only if the second arg is zero! +isDivOp :: PrimOp -> Bool +-- This function probably belongs in PrimOp, or even in +-- an automagically generated file.. but it's such a +-- special case I thought I'd leave it here for now. +isDivOp IntQuotOp = True +isDivOp IntRemOp = True +isDivOp WordQuotOp = True +isDivOp WordRemOp = True +isDivOp FloatDivOp = True +isDivOp DoubleDivOp = True +isDivOp _ = False + +{- Note [exprOkForSpeculation: case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprOkForSpeculation accepts very special case expressions. +Reason: (a ==# b) is ok-for-speculation, but the litEq rules +in PrelRules convert it (a ==# 3#) to + case a of { DEFAULT -> 0#; 3# -> 1# } +for excellent reasons described in + PrelRules Note [The litEq rule: converting equality to case]. +So, annoyingly, we want that case expression to be +ok-for-speculation too. Bother. + +But we restrict it sharply: + +* We restrict it to unlifted scrutinees. Consider this: + case x of y { + DEFAULT -> ... (let v::Int# = case y of { True -> e1 + ; False -> e2 } + in ...) ... + + Does the RHS of v satisfy the let/app invariant? Previously we said + yes, on the grounds that y is evaluated. But the binder-swap done + by SetLevels would transform the inner alternative to + DEFAULT -> ... (let v::Int# = case x of { ... } + in ...) .... + which does /not/ satisfy the let/app invariant, because x is + not evaluated. See Note [Binder-swap during float-out] + in SetLevels. To avoid this awkwardness it seems simpler + to stick to unlifted scrutinees where the issue does not + arise. + +* We restrict it to exhaustive alternatives. A non-exhaustive + case manifestly isn't ok-for-speculation. for example, + this is a valid program (albeit a slightly dodgy one) + let v = case x of { B -> ...; C -> ... } + in case x of + A -> ... + _ -> ...v...v.... + Should v be considered ok-for-speculation? Its scrutinee may be + evaluated, but the alternatives are incomplete so we should not + evaluate it strictly. + + Now, all this is for lifted types, but it'd be the same for any + finite unlifted type. We don't have many of them, but we might + add unlifted algebraic types in due course. + + +----- Historical note: #15696: -------- + Previously SetLevels used exprOkForSpeculation to guide + floating of single-alternative cases; it now uses exprIsHNF + Note [Floating single-alternative cases]. + + But in those days, consider + case e of x { DEAFULT -> + ...(case x of y + A -> ... + _ -> ...(case (case x of { B -> p; C -> p }) of + I# r -> blah)... + If SetLevels considers the inner nested case as + ok-for-speculation it can do case-floating (in SetLevels). + So we'd float to: + case e of x { DEAFULT -> + case (case x of { B -> p; C -> p }) of I# r -> + ...(case x of y + A -> ... + _ -> ...blah...)... + which is utterly bogus (seg fault); see #5453. + +----- Historical note: #3717: -------- + foo :: Int -> Int + foo 0 = 0 + foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) + +In earlier GHCs, we got this: + T.$wfoo = + \ (ww :: GHC.Prim.Int#) -> + case ww of ds { + __DEFAULT -> case (case <# ds 5 of _ { + GHC.Types.False -> lvl1; + GHC.Types.True -> lvl}) + of _ { __DEFAULT -> + T.$wfoo (GHC.Prim.-# ds_XkE 1) }; + 0 -> 0 } + +Before join-points etc we could only get rid of two cases (which are +redundant) by recognising that the (case <# ds 5 of { ... }) is +ok-for-speculation, even though it has /lifted/ type. But now join +points do the job nicely. +------- End of historical note ------------ + + +Note [Primops with lifted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is this ok-for-speculation (see #13027)? + reallyUnsafePtrEq# a b +Well, yes. The primop accepts lifted arguments and does not +evaluate them. Indeed, in general primops are, well, primitive +and do not perform evaluation. + +Bottom line: + * In exprOkForSpeculation we simply ignore all lifted arguments. + * In the rare case of primops that /do/ evaluate their arguments, + (namely DataToTagOp and SeqOp) return False; see + Note [exprOkForSpeculation and evaluated variables] + +Note [exprOkForSpeculation and SeqOp/DataToTagOp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most primops with lifted arguments don't evaluate them +(see Note [Primops with lifted arguments]), so we can ignore +that argument entirely when doing exprOkForSpeculation. + +But DataToTagOp and SeqOp are exceptions to that rule. +For reasons described in Note [exprOkForSpeculation and +evaluated variables], we simply return False for them. + +Not doing this made #5129 go bad. +Lots of discussion in #15696. + +Note [exprOkForSpeculation and evaluated variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall that + seq# :: forall a s. a -> State# s -> (# State# s, a #) + dataToTag# :: forall a. a -> Int# +must always evaluate their first argument. + +Now consider these examples: + * case x of y { DEFAULT -> ....y.... } + Should 'y' (alone) be considered ok-for-speculation? + + * case x of y { DEFAULT -> ....f (dataToTag# y)... } + Should (dataToTag# y) be considered ok-for-spec? + +You could argue 'yes', because in the case alternative we know that +'y' is evaluated. But the binder-swap transformation, which is +extremely useful for float-out, changes these expressions to + case x of y { DEFAULT -> ....x.... } + case x of y { DEFAULT -> ....f (dataToTag# x)... } + +And now the expression does not obey the let/app invariant! Yikes! +Moreover we really might float (f (dataToTag# x)) outside the case, +and then it really, really doesn't obey the let/app invariant. + +The solution is simple: exprOkForSpeculation does not try to take +advantage of the evaluated-ness of (lifted) variables. And it returns +False (always) for DataToTagOp and SeqOp. + +Note that exprIsHNF /can/ and does take advantage of evaluated-ness; +it doesn't have the trickiness of the let/app invariant to worry about. + +************************************************************************ +* * + exprIsHNF, exprIsConLike +* * +************************************************************************ +-} + +-- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] +-- ~~~~~~~~~~~~~~~~ +-- | exprIsHNF returns true for expressions that are certainly /already/ +-- evaluated to /head/ normal form. This is used to decide whether it's ok +-- to change: +-- +-- > case x of _ -> e +-- +-- into: +-- +-- > e +-- +-- and to decide whether it's safe to discard a 'seq'. +-- +-- So, it does /not/ treat variables as evaluated, unless they say they are. +-- However, it /does/ treat partial applications and constructor applications +-- as values, even if their arguments are non-trivial, provided the argument +-- type is lifted. For example, both of these are values: +-- +-- > (:) (f x) (map f xs) +-- > map (...redex...) +-- +-- because 'seq' on such things completes immediately. +-- +-- For unlifted argument types, we have to be careful: +-- +-- > C (f x :: Int#) +-- +-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't +-- happen: see "GHC.Core#let_app_invariant". This invariant states that arguments of +-- unboxed type must be ok-for-speculation (or trivial). +exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP +exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding + +-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as +-- data constructors. Conlike arguments are considered interesting by the +-- inliner. +exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP +exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding + +-- | Returns true for values or value-like expressions. These are lambdas, +-- constructors / CONLIKE functions (as determined by the function argument) +-- or PAPs. +-- +exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool +exprIsHNFlike is_con is_con_unf = is_hnf_like + where + is_hnf_like (Var v) -- NB: There are no value args at this point + = id_app_is_value v 0 -- Catches nullary constructors, + -- so that [] and () are values, for example + -- and (e.g.) primops that don't have unfoldings + || is_con_unf (idUnfolding v) + -- Check the thing's unfolding; it might be bound to a value + -- or to a guaranteed-evaluated variable (isEvaldUnfolding) + -- Contrast with Note [exprOkForSpeculation and evaluated variables] + -- We don't look through loop breakers here, which is a bit conservative + -- but otherwise I worry that if an Id's unfolding is just itself, + -- we could get an infinite loop + + is_hnf_like (Lit _) = True + is_hnf_like (Type _) = True -- Types are honorary Values; + -- we don't mind copying them + is_hnf_like (Coercion _) = True -- Same for coercions + is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e + is_hnf_like (Tick tickish e) = not (tickishCounts tickish) + && is_hnf_like e + -- See Note [exprIsHNF Tick] + is_hnf_like (Cast e _) = is_hnf_like e + is_hnf_like (App e a) + | isValArg a = app_is_value e 1 + | otherwise = is_hnf_like e + is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us + is_hnf_like _ = False + + -- 'n' is the number of value args to which the expression is applied + -- And n>0: there is at least one value argument + app_is_value :: CoreExpr -> Int -> Bool + app_is_value (Var f) nva = id_app_is_value f nva + app_is_value (Tick _ f) nva = app_is_value f nva + app_is_value (Cast f _) nva = app_is_value f nva + app_is_value (App f a) nva + | isValArg a = app_is_value f (nva + 1) + | otherwise = app_is_value f nva + app_is_value _ _ = False + + id_app_is_value id n_val_args + = is_con id + || idArity id > n_val_args + || id `hasKey` absentErrorIdKey -- See Note [aBSENT_ERROR_ID] in GHC.Core.Make + -- absentError behaves like an honorary data constructor + + +{- +Note [exprIsHNF Tick] + +We can discard source annotations on HNFs as long as they aren't +tick-like: + + scc c (\x . e) => \x . e + scc c (C x1..xn) => C x1..xn + +So we regard these as HNFs. Tick annotations that tick are not +regarded as HNF if the expression they surround is HNF, because the +tick is there to tell us that the expression was evaluated, so we +don't want to discard a seq on it. +-} + +-- | Can we bind this 'CoreExpr' at the top level? +exprIsTopLevelBindable :: CoreExpr -> Type -> Bool +-- See Note [Core top-level string literals] +-- Precondition: exprType expr = ty +-- Top-level literal strings can't even be wrapped in ticks +-- see Note [Core top-level string literals] in GHC.Core +exprIsTopLevelBindable expr ty + = not (mightBeUnliftedType ty) + -- Note that 'expr' may be levity polymorphic here consequently we must use + -- 'mightBeUnliftedType' rather than 'isUnliftedType' as the latter would panic. + || exprIsTickedString expr + +-- | Check if the expression is zero or more Ticks wrapped around a literal +-- string. +exprIsTickedString :: CoreExpr -> Bool +exprIsTickedString = isJust . exprIsTickedString_maybe + +-- | Extract a literal string from an expression that is zero or more Ticks +-- wrapped around a literal string. Returns Nothing if the expression has a +-- different shape. +-- Used to "look through" Ticks in places that need to handle literal strings. +exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString +exprIsTickedString_maybe (Lit (LitString bs)) = Just bs +exprIsTickedString_maybe (Tick t e) + -- we don't tick literals with CostCentre ticks, compare to mkTick + | tickishPlace t == PlaceCostCentre = Nothing + | otherwise = exprIsTickedString_maybe e +exprIsTickedString_maybe _ = Nothing + +{- +************************************************************************ +* * + Instantiating data constructors +* * +************************************************************************ + +These InstPat functions go here to avoid circularity between DataCon and Id +-} + +dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id]) +dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id]) + +dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) +dataConRepFSInstPat = dataConInstPat + +dataConInstPat :: [FastString] -- A long enough list of FSs to use for names + -> [Unique] -- An equally long list of uniques, at least one for each binder + -> DataCon + -> [Type] -- Types to instantiate the universally quantified tyvars + -> ([TyCoVar], [Id]) -- Return instantiated variables +-- dataConInstPat arg_fun fss us con inst_tys returns a tuple +-- (ex_tvs, arg_ids), +-- +-- ex_tvs are intended to be used as binders for existential type args +-- +-- arg_ids are indended to be used as binders for value arguments, +-- and their types have been instantiated with inst_tys and ex_tys +-- The arg_ids include both evidence and +-- programmer-specified arguments (both after rep-ing) +-- +-- Example. +-- The following constructor T1 +-- +-- data T a where +-- T1 :: forall b. Int -> b -> T(a,b) +-- ... +-- +-- has representation type +-- forall a. forall a1. forall b. (a ~ (a1,b)) => +-- Int -> b -> T a +-- +-- dataConInstPat fss us T1 (a1',b') will return +-- +-- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) +-- +-- where the double-primed variables are created with the FastStrings and +-- Uniques given as fss and us +dataConInstPat fss uniqs con inst_tys + = ASSERT( univ_tvs `equalLength` inst_tys ) + (ex_bndrs, arg_ids) + where + univ_tvs = dataConUnivTyVars con + ex_tvs = dataConExTyCoVars con + arg_tys = dataConRepArgTys con + arg_strs = dataConRepStrictness con -- 1-1 with arg_tys + n_ex = length ex_tvs + + -- split the Uniques and FastStrings + (ex_uniqs, id_uniqs) = splitAt n_ex uniqs + (ex_fss, id_fss) = splitAt n_ex fss + + -- Make the instantiating substitution for universals + univ_subst = zipTvSubst univ_tvs inst_tys + + -- Make existential type variables, applying and extending the substitution + (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst + (zip3 ex_tvs ex_fss ex_uniqs) + + mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar) + mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv + new_tv + , new_tv) + where + new_tv | isTyVar tv + = mkTyVar (mkSysTvName uniq fs) kind + | otherwise + = mkCoVar (mkSystemVarName uniq fs) kind + kind = Type.substTyUnchecked subst (varType tv) + + -- Make value vars, instantiating types + arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs + mk_id_var uniq fs ty str + = setCaseBndrEvald str $ -- See Note [Mark evaluated arguments] + mkLocalIdOrCoVar name (Type.substTy full_subst ty) + where + name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan + +{- +Note [Mark evaluated arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pattern matching on a constructor with strict fields, the binder +can have an 'evaldUnfolding'. Moreover, it *should* have one, so that +when loading an interface file unfolding like: + data T = MkT !Int + f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 + in ... } +we don't want Lint to complain. The 'y' is evaluated, so the +case in the RHS of the binding for 'v' is fine. But only if we +*know* that 'y' is evaluated. + +c.f. add_evals in Simplify.simplAlt + +************************************************************************ +* * + Equality +* * +************************************************************************ +-} + +-- | A cheap equality test which bales out fast! +-- If it returns @True@ the arguments are definitely equal, +-- otherwise, they may or may not be equal. +-- +-- See also 'exprIsBig' +cheapEqExpr :: Expr b -> Expr b -> Bool +cheapEqExpr = cheapEqExpr' (const False) + +-- | Cheap expression equality test, can ignore ticks by type. +cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool +cheapEqExpr' ignoreTick = go_s + where go_s = go `on` stripTicksTopE ignoreTick + go (Var v1) (Var v2) = v1 == v2 + go (Lit lit1) (Lit lit2) = lit1 == lit2 + go (Type t1) (Type t2) = t1 `eqType` t2 + go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 + + go (App f1 a1) (App f2 a2) + = f1 `go_s` f2 && a1 `go_s` a2 + + go (Cast e1 t1) (Cast e2 t2) + = e1 `go_s` e2 && t1 `eqCoercion` t2 + + go (Tick t1 e1) (Tick t2 e2) + = t1 == t2 && e1 `go_s` e2 + + go _ _ = False + {-# INLINE go #-} +{-# INLINE cheapEqExpr' #-} + +exprIsBig :: Expr b -> Bool +-- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' +exprIsBig (Lit _) = False +exprIsBig (Var _) = False +exprIsBig (Type _) = False +exprIsBig (Coercion _) = False +exprIsBig (Lam _ e) = exprIsBig e +exprIsBig (App f a) = exprIsBig f || exprIsBig a +exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! +exprIsBig (Tick _ e) = exprIsBig e +exprIsBig _ = True + +eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool +-- Compares for equality, modulo alpha +eqExpr in_scope e1 e2 + = go (mkRnEnv2 in_scope) e1 e2 + where + go env (Var v1) (Var v2) + | rnOccL env v1 == rnOccR env v2 + = True + + go _ (Lit lit1) (Lit lit2) = lit1 == lit2 + go env (Type t1) (Type t2) = eqTypeX env t1 t2 + go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2 + go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2 + go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 + go env (Tick n1 e1) (Tick n2 e2) = eqTickish env n1 n2 && go env e1 e2 + + go env (Lam b1 e1) (Lam b2 e2) + = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + && go (rnBndr2 env b1 b2) e1 e2 + + go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) + = go env r1 r2 -- No need to check binder types, since RHSs match + && go (rnBndr2 env v1 v2) e1 e2 + + go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) + = equalLength ps1 ps2 + && all2 (go env') rs1 rs2 && go env' e1 e2 + where + (bs1,rs1) = unzip ps1 + (bs2,rs2) = unzip ps2 + env' = rnBndrs2 env bs1 bs2 + + go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | null a1 -- See Note [Empty case alternatives] in TrieMap + = null a2 && go env e1 e2 && eqTypeX env t1 t2 + | otherwise + = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 + + go _ _ _ = False + + ----------- + go_alt env (c1, bs1, e1) (c2, bs2, e2) + = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 + +eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool +eqTickish env (Breakpoint lid lids) (Breakpoint rid rids) + = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids +eqTickish _ l r = l == r + +-- | Finds differences between core expressions, modulo alpha and +-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be +-- checked for differences as well. +diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] +diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] +diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] +diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] +diffExpr _ env (Coercion co1) (Coercion co2) + | eqCoercionX env co1 co2 = [] +diffExpr top env (Cast e1 co1) (Cast e2 co2) + | eqCoercionX env co1 co2 = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) e2 + | not (tickishIsCode n1) = diffExpr top env e1 e2 +diffExpr top env e1 (Tick n2 e2) + | not (tickishIsCode n2) = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) (Tick n2 e2) + | eqTickish env n1 n2 = diffExpr top env e1 e2 + -- The error message of failed pattern matches will contain + -- generated names, which are allowed to differ. +diffExpr _ _ (App (App (Var absent) _) _) + (App (App (Var absent2) _) _) + | isBottomingId absent && isBottomingId absent2 = [] +diffExpr top env (App f1 a1) (App f2 a2) + = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 +diffExpr top env (Lam b1 e1) (Lam b2 e2) + | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + = diffExpr top (rnBndr2 env b1 b2) e1 e2 +diffExpr top env (Let bs1 e1) (Let bs2 e2) + = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) + in ds ++ diffExpr top env' e1 e2 +diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2 + -- See Note [Empty case alternatives] in TrieMap + = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) + where env' = rnBndr2 env b1 b2 + diffAlt (c1, bs1, e1) (c2, bs2, e2) + | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] + | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 +diffExpr _ _ e1 e2 + = [fsep [ppr e1, text "/=", ppr e2]] + +-- | Finds differences between core bindings, see @diffExpr@. +-- +-- The main problem here is that while we expect the binds to have the +-- same order in both lists, this is not guaranteed. To do this +-- properly we'd either have to do some sort of unification or check +-- all possible mappings, which would be seriously expensive. So +-- instead we simply match single bindings as far as we can. This +-- leaves us just with mutually recursive and/or mismatching bindings, +-- which we then speculatively match by ordering them. It's by no means +-- perfect, but gets the job done well enough. +diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] + -> ([SDoc], RnEnv2) +diffBinds top env binds1 = go (length binds1) env binds1 + where go _ env [] [] + = ([], env) + go fuel env binds1 binds2 + -- No binds left to compare? Bail out early. + | null binds1 || null binds2 + = (warn env binds1 binds2, env) + -- Iterated over all binds without finding a match? Then + -- try speculatively matching binders by order. + | fuel == 0 + = if not $ env `inRnEnvL` fst (head binds1) + then let env' = uncurry (rnBndrs2 env) $ unzip $ + zip (sort $ map fst binds1) (sort $ map fst binds2) + in go (length binds1) env' binds1 binds2 + -- If we have already tried that, give up + else (warn env binds1 binds2, env) + go fuel env ((bndr1,expr1):binds1) binds2 + | let matchExpr (bndr,expr) = + (not top || null (diffIdInfo env bndr bndr1)) && + null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr) + , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2 + = go (length binds1) (rnBndr2 env bndr1 bndr2) + binds1 (binds2l ++ binds2r) + | otherwise -- No match, so push back (FIXME O(n^2)) + = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 + go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough + + -- We have tried everything, but couldn't find a good match. So + -- now we just return the comparison results when we pair up + -- the binds in a pseudo-random order. + warn env binds1 binds2 = + concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++ + unmatched "unmatched left-hand:" (drop l binds1') ++ + unmatched "unmatched right-hand:" (drop l binds2') + where binds1' = sortBy (comparing fst) binds1 + binds2' = sortBy (comparing fst) binds2 + l = min (length binds1') (length binds2') + unmatched _ [] = [] + unmatched txt bs = [text txt $$ ppr (Rec bs)] + diffBind env (bndr1,expr1) (bndr2,expr2) + | ds@(_:_) <- diffExpr top env expr1 expr2 + = locBind "in binding" bndr1 bndr2 ds + | otherwise + = diffIdInfo env bndr1 bndr2 + +-- | Find differences in @IdInfo@. We will especially check whether +-- the unfoldings match, if present (see @diffUnfold@). +diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc] +diffIdInfo env bndr1 bndr2 + | arityInfo info1 == arityInfo info2 + && cafInfo info1 == cafInfo info2 + && oneShotInfo info1 == oneShotInfo info2 + && inlinePragInfo info1 == inlinePragInfo info2 + && occInfo info1 == occInfo info2 + && demandInfo info1 == demandInfo info2 + && callArityInfo info1 == callArityInfo info2 + && levityInfo info1 == levityInfo info2 + = locBind "in unfolding of" bndr1 bndr2 $ + diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2) + | otherwise + = locBind "in Id info of" bndr1 bndr2 + [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]] + where info1 = idInfo bndr1; info2 = idInfo bndr2 + +-- | Find differences in unfoldings. Note that we will not check for +-- differences of @IdInfo@ in unfoldings, as this is generally +-- redundant, and can lead to an exponential blow-up in complexity. +diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc] +diffUnfold _ NoUnfolding NoUnfolding = [] +diffUnfold _ BootUnfolding BootUnfolding = [] +diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = [] +diffUnfold env (DFunUnfolding bs1 c1 a1) + (DFunUnfolding bs2 c2 a2) + | c1 == c2 && equalLength bs1 bs2 + = concatMap (uncurry (diffExpr False env')) (zip a1 a2) + where env' = rnBndrs2 env bs1 bs2 +diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1) + (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2) + | v1 == v2 && cl1 == cl2 + && wf1 == wf2 && x1 == x2 && g1 == g2 + = diffExpr False env t1 t2 +diffUnfold _ uf1 uf2 + = [fsep [ppr uf1, text "/=", ppr uf2]] + +-- | Add location information to diff messages +locBind :: String -> Var -> Var -> [SDoc] -> [SDoc] +locBind loc b1 b2 diffs = map addLoc diffs + where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc)) + bindLoc | b1 == b2 = ppr b1 + | otherwise = ppr b1 <> char '/' <> ppr b2 + +{- +************************************************************************ +* * + Eta reduction +* * +************************************************************************ + +Note [Eta reduction conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We try for eta reduction here, but *only* if we get all the way to an +trivial expression. We don't want to remove extra lambdas unless we +are going to avoid allocating this thing altogether. + +There are some particularly delicate points here: + +* We want to eta-reduce if doing so leaves a trivial expression, + *including* a cast. For example + \x. f |> co --> f |> co + (provided co doesn't mention x) + +* Eta reduction is not valid in general: + \x. bot /= bot + This matters, partly for old-fashioned correctness reasons but, + worse, getting it wrong can yield a seg fault. 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). BUT, as thing 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 termninate after all. + Result: seg-fault because the boolean case actually gets a function value. + See #1947. + + So it's important to do the right thing. + +* Note [Arity care]: we need to be careful if we just look at f's + arity. Currently (Dec07), f's arity is visible in its own RHS (see + Note [Arity robustness] in SimplEnv) so we must *not* trust the + arity when checking that 'f' is a value. Otherwise we will + eta-reduce + f = \x. f x + to + f = f + Which might change a terminating program (think (f `seq` e)) to a + non-terminating one. So we check for being a loop breaker first. + + However for GlobalIds we can look at the arity; and for primops we + must, since they have no unfolding. + +* Regardless of whether 'f' is a value, we always want to + reduce (/\a -> f a) to f + This came up in a RULE: foldr (build (/\a -> g a)) + did not match foldr (build (/\b -> ...something complex...)) + The type checker can insert these eta-expanded versions, + with both type and dictionary lambdas; hence the slightly + ad-hoc isDictId + +* 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 + +These delicacies are why we don't use exprIsTrivial and exprIsHNF here. +Alas. + +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. + +It's true that we could also hope to eta reduce these: + (\xy. (f x |> g) y) + (\xy. (f x y) |> g) +But the simplifier pushes those casts outwards, so we don't +need to address that here. +-} + +-- When updating this function, make sure to update +-- CorePrep.tryEtaReducePrep as well! +tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr +tryEtaReduce bndrs body + = go (reverse bndrs) body (mkRepReflCo (exprType body)) + where + incoming_arity = count isId bndrs + + 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 + go [] fun co + | ok_fun fun + , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co + , not (any (`elemVarSet` used_vars) bndrs) + = Just (mkCast fun co) -- Check for any of the binders free in the result + -- including the accumulated coercion + + go bs (Tick t e) co + | tickishFloatable t + = fmap (Tick t) $ go bs e co + -- Float app ticks: \x -> Tick t (e x) ==> Tick t e + + go (b : bs) (App fun arg) co + | Just (co', ticks) <- ok_arg b arg co + = fmap (flip (foldr mkTick) ticks) $ go bs fun co' + -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e + + go _ _ _ = Nothing -- Failure! + + --------------- + -- Note [Eta reduction conditions] + ok_fun (App fun (Type {})) = ok_fun fun + ok_fun (Cast fun _) = ok_fun fun + ok_fun (Tick _ expr) = ok_fun expr + ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs + ok_fun _fun = False + + --------------- + ok_fun_id fun = fun_arity fun >= incoming_arity + + --------------- + fun_arity fun -- See Note [Arity care] + | isLocalId fun + , isStrongLoopBreaker (idOccInfo fun) = 0 + | arity > 0 = arity + | isEvaldUnfolding (idUnfolding fun) = 1 + -- See Note [Eta reduction of an eval'd function] + | otherwise = 0 + where + arity = idArity fun + + --------------- + ok_lam v = isTyVar v || isEvVar v + + --------------- + ok_arg :: Var -- Of type bndr_t + -> CoreExpr -- Of type arg_t + -> Coercion -- Of kind (t1~t2) + -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -- (and similarly for tyvars, coercion args) + , [Tickish Var]) + -- See Note [Eta reduction with casted arguments] + ok_arg bndr (Type ty) co + | Just tv <- getTyVar_maybe ty + , bndr == tv = Just (mkHomoForAllCos [tv] co, []) + ok_arg bndr (Var v) co + | bndr == v = let reflCo = mkRepReflCo (idType bndr) + in Just (mkFunCo Representational reflCo co, []) + ok_arg bndr (Cast e co_arg) co + | (ticks, Var v) <- stripTicksTop tickishFloatable e + , bndr == v + = Just (mkFunCo Representational (mkSymCo co_arg) co, ticks) + -- The simplifier combines multiple casts into one, + -- so we can have a simple-minded pattern match here + ok_arg bndr (Tick t arg) co + | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co + = Just (co', t:ticks) + + ok_arg _ _ _ = Nothing + +{- +Note [Eta reduction of an eval'd function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Haskell it is not true that f = \x. f x +because f might be bottom, and 'seq' can distinguish them. + +But it *is* true that f = f `seq` \x. f x +and we'd like to simplify the latter to the former. This amounts +to the rule that + * when there is just *one* value argument, + * f is not bottom +we can eta-reduce \x. f x ===> f + +This turned up in #7542. + + +************************************************************************ +* * +\subsection{Determining non-updatable right-hand-sides} +* * +************************************************************************ + +Top-level constructor applications can usually be allocated +statically, but they can't if the constructor, or any of the +arguments, come from another DLL (because we can't refer to static +labels in other DLLs). + +If this happens we simply make the RHS into an updatable thunk, +and 'execute' it rather than allocating it statically. +-} + +{- +************************************************************************ +* * +\subsection{Type utilities} +* * +************************************************************************ +-} + +-- | True if the type has no non-bottom elements, e.g. when it is an empty +-- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool. +-- See Note [Bottoming expressions] +-- +-- See Note [No alternatives lint check] for another use of this function. +isEmptyTy :: Type -> Bool +isEmptyTy ty + -- Data types where, given the particular type parameters, no data + -- constructor matches, are empty. + -- This includes data types with no constructors, e.g. Data.Void.Void. + | Just (tc, inst_tys) <- splitTyConApp_maybe ty + , Just dcs <- tyConDataCons_maybe tc + , all (dataConCannotMatch inst_tys) dcs + = True + | otherwise + = False + +{- +***************************************************** +* +* StaticPtr +* +***************************************************** +-} + +-- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields +-- @Just (makeStatic, t, srcLoc, e)@. +-- +-- Returns @Nothing@ for every other expression. +collectMakeStaticArgs + :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr) +collectMakeStaticArgs e + | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e + , idName b == makeStaticName = Just (fun, t, loc, arg) +collectMakeStaticArgs _ = Nothing + +{- +************************************************************************ +* * +\subsection{Join points} +* * +************************************************************************ +-} + +-- | Does this binding bind a join point (or a recursive group of join points)? +isJoinBind :: CoreBind -> Bool +isJoinBind (NonRec b _) = isJoinId b +isJoinBind (Rec ((b, _) : _)) = isJoinId b +isJoinBind _ = False + +dumpIdInfoOfProgram :: (IdInfo -> SDoc) -> CoreProgram -> SDoc +dumpIdInfoOfProgram ppr_id_info binds = vcat (map printId ids) + where + ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds) + getIds (NonRec i _) = [ i ] + getIds (Rec bs) = map fst bs + printId id | isExportedId id = ppr id <> colon <+> (ppr_id_info (idInfo id)) + | otherwise = empty |