From b04296d3a3a256067787241a7727877e35e5af03 Mon Sep 17 00:00:00 2001 From: Austin Seipp Date: Wed, 3 Dec 2014 12:43:05 -0600 Subject: compiler: de-lhs coreSyn/ Signed-off-by: Austin Seipp --- compiler/coreSyn/CoreArity.hs | 1003 +++++++++++++++++++++ compiler/coreSyn/CoreArity.lhs | 1004 --------------------- compiler/coreSyn/CoreFVs.hs | 533 ++++++++++++ compiler/coreSyn/CoreFVs.lhs | 545 ------------ compiler/coreSyn/CoreLint.hs | 1442 ++++++++++++++++++++++++++++++ compiler/coreSyn/CoreLint.lhs | 1471 ------------------------------- compiler/coreSyn/CorePrep.hs | 1208 ++++++++++++++++++++++++++ compiler/coreSyn/CorePrep.lhs | 1211 -------------------------- compiler/coreSyn/CoreSubst.hs | 1408 ++++++++++++++++++++++++++++++ compiler/coreSyn/CoreSubst.lhs | 1422 ------------------------------ compiler/coreSyn/CoreSyn.hs | 1502 ++++++++++++++++++++++++++++++++ compiler/coreSyn/CoreSyn.lhs | 1523 -------------------------------- compiler/coreSyn/CoreTidy.hs | 272 ++++++ compiler/coreSyn/CoreTidy.lhs | 276 ------ compiler/coreSyn/CoreUnfold.hs | 1432 ++++++++++++++++++++++++++++++ compiler/coreSyn/CoreUnfold.lhs | 1442 ------------------------------ compiler/coreSyn/CoreUtils.hs | 1807 ++++++++++++++++++++++++++++++++++++++ compiler/coreSyn/CoreUtils.lhs | 1829 --------------------------------------- compiler/coreSyn/MkCore.hs | 774 +++++++++++++++++ compiler/coreSyn/MkCore.lhs | 792 ----------------- compiler/coreSyn/PprCore.hs | 527 +++++++++++ compiler/coreSyn/PprCore.lhs | 536 ------------ compiler/coreSyn/TrieMap.hs | 829 ++++++++++++++++++ compiler/coreSyn/TrieMap.lhs | 840 ------------------ 24 files changed, 12737 insertions(+), 12891 deletions(-) create mode 100644 compiler/coreSyn/CoreArity.hs delete mode 100644 compiler/coreSyn/CoreArity.lhs create mode 100644 compiler/coreSyn/CoreFVs.hs delete mode 100644 compiler/coreSyn/CoreFVs.lhs create mode 100644 compiler/coreSyn/CoreLint.hs delete mode 100644 compiler/coreSyn/CoreLint.lhs create mode 100644 compiler/coreSyn/CorePrep.hs delete mode 100644 compiler/coreSyn/CorePrep.lhs create mode 100644 compiler/coreSyn/CoreSubst.hs delete mode 100644 compiler/coreSyn/CoreSubst.lhs create mode 100644 compiler/coreSyn/CoreSyn.hs delete mode 100644 compiler/coreSyn/CoreSyn.lhs create mode 100644 compiler/coreSyn/CoreTidy.hs delete mode 100644 compiler/coreSyn/CoreTidy.lhs create mode 100644 compiler/coreSyn/CoreUnfold.hs delete mode 100644 compiler/coreSyn/CoreUnfold.lhs create mode 100644 compiler/coreSyn/CoreUtils.hs delete mode 100644 compiler/coreSyn/CoreUtils.lhs create mode 100644 compiler/coreSyn/MkCore.hs delete mode 100644 compiler/coreSyn/MkCore.lhs create mode 100644 compiler/coreSyn/PprCore.hs delete mode 100644 compiler/coreSyn/PprCore.lhs create mode 100644 compiler/coreSyn/TrieMap.hs delete mode 100644 compiler/coreSyn/TrieMap.lhs diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs new file mode 100644 index 0000000000..5128891763 --- /dev/null +++ b/compiler/coreSyn/CoreArity.hs @@ -0,0 +1,1003 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + + Arity and eta expansion +-} + +{-# LANGUAGE CPP #-} + +-- | Arity and eta expansion +module CoreArity ( + manifestArity, exprArity, typeArity, exprBotStrictness_maybe, + exprEtaExpandArity, findRhsArity, CheapFun, etaExpand + ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreFVs +import CoreUtils +import CoreSubst +import Demand +import Var +import VarEnv +import Id +import Type +import TyCon ( initRecTc, checkRecTc ) +import Coercion +import BasicTypes +import Unique +import DynFlags ( DynFlags, GeneralFlag(..), gopt ) +import Outputable +import FastString +import Pair +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 + +--------------- +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) (pSnd (coercionKind 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) botRes + -- For this purpose we can be very simple + +{- +Note [exprArity invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprArity has the following invariant: + + (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 TidyPgm we use exprArity to fix the *final arity* of + each top-level Id, and in + - In CorePrep we use etaExpand on each rhs, so that the visible lambdas + actually match that arity, which in turn means + that the StgRhs has the right number of lambdas + +An alternative would be to do the eta-expansion in TidyPgm, at least +for top-level bindings, in which case we would not need the trim_arity +in exprArity. That is a less local change, so I'm going to leave it for today! + +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 Trac #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. + 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 divegent case, no work is lost by duplicating because if the thing +is evaluated once, that's the end of the program. + +Or, to put it another way, in any context C + + C[ (\x1 .. xn. e x1 .. xn) ] + is as efficient as + C[ e ] + +It's all a bit more subtle than it looks: + +Note [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 +Trac #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 bahaviour 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 Trac #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 Trac #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 + decopose Int to a function type. Hence the final case in eta_expand. + +Note [The state-transformer hack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + f = e +where e has arity n. Then, if we know from the context that f has +a usage type like + t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... +then we can expand the arity to m. This usage type says that +any application (x e1 .. en) will be applied to uniquely to (m-n) more args +Consider f = \x. let y = + in case x of + True -> foo + False -> \(s:RealWorld) -> e +where foo has arity 1. Then we want the state hack to +apply to foo too, so we can eta expand the case. + +Then we expect that if f is applied to one arg, it'll be applied to two +(that's the hack -- we don't really know, and sometimes it's false) +See also Id.isOneShotBndr. + +Note [State hack and bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's a terrible idea to use the state hack on a bottoming function. +Here's what happens (Trac #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 Trac #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 = in \y. error (g x y) + ==> \y. let x = 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 of + its definition. + + NB 'f' is an arbitary 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 = 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 :: 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 + +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 _ -> exprIsCheap' cheap_app e + | otherwise + = \e mb_ty -> exprIsCheap' cheap_app e + || case mb_ty of + Nothing -> False + Just ty -> isDictLikeTy ty + + +---------------------- +findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity +-- This implements the fixpoint loop for arity analysis +-- See Note [Arity analysis] +findRhsArity dflags bndr rhs old_arity + = go (rhsEtaExpandArity dflags init_cheap_app rhs) + -- 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 + 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 -> Arity + go cur_arity + | cur_arity <= old_arity = cur_arity + | new_arity == cur_arity = cur_arity + | otherwise = ASSERT( new_arity < cur_arity ) +#ifdef DEBUG + pprTrace "Exciting arity" + (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity + , ppr rhs]) +#endif + go new_arity + where + new_arity = rhsEtaExpandArity dflags cheap_app rhs + + cheap_app :: CheapAppFun + cheap_app fn n_val_args + | fn == bndr = n_val_args < cur_arity + | otherwise = isCheapApp fn n_val_args + +-- ^ The Arity returned is the number of value args the +-- expression can be applied to without doing much work +rhsEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity +-- exprEtaExpandArity is used when eta expanding +-- e ==> \xy -> e x y +rhsEtaExpandArity dflags cheap_app e + = case (arityType env e) of + ATop (os:oss) + | isOneShotInfo os || has_lam e -> 1 + length oss + -- Don't expand PAPs/thunks + -- Note [Eta expanding thunks] + | otherwise -> 0 + ATop [] -> 0 + ABot n -> n + where + env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app + , ae_ped_bot = gopt Opt_PedanticBottoms dflags } + + has_lam (Tick _ e) = has_lam e + has_lam (Lam b e) = isId b || has_lam e + has_lam _ = False + +{- +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 Trac #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 exprIsCheap' 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. + +See Note [Dictionary-like types] in TcType.lhs for why we use +isDictLikeTy here rather than isDictTy + +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 (idOneShotInfo 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 `min` n2) +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 [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 barnches 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. +-} + +--------------------------- +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) + ABot n -> ABot (n `min` co_arity) + where + co_arity = length (typeArity (pSnd (coercionKind 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 + -- Trac #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 $ isNopSig strict_sig + , (ds, res) <- splitStrictSig strict_sig + , let arity = length ds + = if isBotRes 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 alernative, 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 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" +-} + +-- | @etaExpand n us e ty@ returns an expression with +-- the same meaning as @e@, but with arity @n@. +-- +-- Given: +-- +-- > e' = etaExpand n us e ty +-- +-- We should have that: +-- +-- > ty = exprType e = exprType e' +etaExpand :: Arity -- ^ Result should have this number of value args + -> CoreExpr -- ^ Expression to expand + -> CoreExpr +-- 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 + -- 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]) $ + etaInfoAbs etas (etaInfoApp subst' expr etas) + where + in_scope = mkInScopeSet (exprFreeVars expr) + (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr) + subst' = mkEmptySubst in_scope' + + -- Wrapper Unwrapper +-------------- +data EtaInfo = EtaVar Var -- /\a. [], [] a + -- \x. [], [] x + | EtaCo Coercion -- [] |> co, [] |> (sym co) + +instance Outputable EtaInfo where + ppr (EtaVar v) = ptext (sLit "EtaVar") <+> ppr v + ppr (EtaCo co) = ptext (sLit "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 (CoreSubst.extendSubstWithVar subst v1 v2) e eis + +etaInfoApp subst (Cast e co1) eis + = etaInfoApp subst e (pushCoercion co' eis) + where + co' = CoreSubst.substCo subst co1 + +etaInfoApp subst (Case e b ty alts) eis + = Case (subst_expr subst e) b1 (mk_alts_ty (CoreSubst.substTy subst ty) eis) alts' + where + (subst1, b1) = substBndr subst b + alts' = map subst_alt alts + subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) + where + (subst2,bs') = substBndrs subst1 bs + + mk_alts_ty ty [] = ty + mk_alts_ty ty (EtaVar v : eis) = mk_alts_ty (applyTypeToArg ty (varToCoreExpr v)) eis + mk_alts_ty _ (EtaCo co : eis) = mk_alts_ty (pSnd (coercionKind co)) eis + +etaInfoApp subst (Let b e) eis + = Let b' (etaInfoApp subst' e eis) + where + (subst', b') = subst_bind subst b + +etaInfoApp subst (Tick t e) eis + = Tick (substTickish subst t) (etaInfoApp subst e eis) + +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 + +-------------- +mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type + -> (InScopeSet, [EtaInfo]) + -- EtaInfo contains fresh variables, + -- not free in the incoming CoreExpr + -- Outgoing InScopeSet includes the EtaInfo vars + -- and the original free vars + +mkEtaWW orig_n orig_expr in_scope orig_ty + = go orig_n empty_subst orig_ty [] + where + empty_subst = TvSubst in_scope emptyTvSubstEnv + + go n subst ty eis -- See Note [exprArity invariant] + | n == 0 + = (getTvInScope subst, reverse eis) + + | Just (tv,ty') <- splitForAllTy_maybe ty + , let (subst', tv') = Type.substTyVarBndr subst tv + -- Avoid free vars of the original expression + = go n subst' ty' (EtaVar tv' : eis) + + | Just (arg_ty, res_ty) <- splitFunTy_maybe ty + , 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) + + | Just (co, ty') <- topNormaliseNewType_maybe ty + = -- 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) + go n subst ty' (EtaCo co : eis) + + | otherwise -- We have an expression of arity > 0, + -- but its type isn't a function. + = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr ) + (getTvInScope subst, reverse eis) + -- This *can* legitmately happen: + -- e.g. coerce Int (\x. x) Essentially the programmer is + -- playing fast and loose with types (Happy does this a lot). + -- So we simply decline to eta-expand. Otherwise we'd end up + -- with an explicit lambda having a non-function type + + +-------------- +-- Avoiding unnecessary substitution; use short-cutting versions + +subst_expr :: Subst -> CoreExpr -> CoreExpr +subst_expr = substExprSC (text "CoreArity:substExpr") + +subst_bind :: Subst -> CoreBind -> (Subst, CoreBind) +subst_bind = substBindSC + + +-------------- +freshEtaId :: Int -> TvSubst -> Type -> (TvSubst, 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.substTy subst ty + eta_id' = uniqAway (getTvInScope subst) $ + mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty' + subst' = extendTvInScope subst eta_id' diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs deleted file mode 100644 index 37517d6190..0000000000 --- a/compiler/coreSyn/CoreArity.lhs +++ /dev/null @@ -1,1004 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - - Arity and eta expansion - -\begin{code} -{-# LANGUAGE CPP #-} - --- | Arity and eta expansion -module CoreArity ( - manifestArity, exprArity, typeArity, exprBotStrictness_maybe, - exprEtaExpandArity, findRhsArity, CheapFun, etaExpand - ) where - -#include "HsVersions.h" - -import CoreSyn -import CoreFVs -import CoreUtils -import CoreSubst -import Demand -import Var -import VarEnv -import Id -import Type -import TyCon ( initRecTc, checkRecTc ) -import Coercion -import BasicTypes -import Unique -import DynFlags ( DynFlags, GeneralFlag(..), gopt ) -import Outputable -import FastString -import Pair -import Util ( debugIsOn ) -\end{code} - -%************************************************************************ -%* * - 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. - -\begin{code} -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 - ---------------- -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) (pSnd (coercionKind 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) botRes - -- For this purpose we can be very simple -\end{code} - -Note [exprArity invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -exprArity has the following invariant: - - (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 TidyPgm we use exprArity to fix the *final arity* of - each top-level Id, and in - - In CorePrep we use etaExpand on each rhs, so that the visible lambdas - actually match that arity, which in turn means - that the StgRhs has the right number of lambdas - -An alternative would be to do the eta-expansion in TidyPgm, at least -for top-level bindings, in which case we would not need the trim_arity -in exprArity. That is a less local change, so I'm going to leave it for today! - -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 Trac #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. - 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 divegent case, no work is lost by duplicating because if the thing -is evaluated once, that's the end of the program. - -Or, to put it another way, in any context C - - C[ (\x1 .. xn. e x1 .. xn) ] - is as efficient as - C[ e ] - -It's all a bit more subtle than it looks: - -Note [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 -Trac #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 bahaviour 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 Trac #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 Trac #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 - decopose Int to a function type. Hence the final case in eta_expand. - -Note [The state-transformer hack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - f = e -where e has arity n. Then, if we know from the context that f has -a usage type like - t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... -then we can expand the arity to m. This usage type says that -any application (x e1 .. en) will be applied to uniquely to (m-n) more args -Consider f = \x. let y = - in case x of - True -> foo - False -> \(s:RealWorld) -> e -where foo has arity 1. Then we want the state hack to -apply to foo too, so we can eta expand the case. - -Then we expect that if f is applied to one arg, it'll be applied to two -(that's the hack -- we don't really know, and sometimes it's false) -See also Id.isOneShotBndr. - -Note [State hack and bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's a terrible idea to use the state hack on a bottoming function. -Here's what happens (Trac #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 Trac #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 = in \y. error (g x y) - ==> \y. let x = 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 of - its definition. - - NB 'f' is an arbitary 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 = 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 :: AT [] ATop - --------------------- Main arity code ---------------------------- -\begin{code} --- See Note [ArityType] -data ArityType = ATop [OneShotInfo] | ABot Arity - -- There is always an explicit lambda - -- to justify the [OneShot], or the Arity - -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 _ -> exprIsCheap' cheap_app e - | otherwise - = \e mb_ty -> exprIsCheap' cheap_app e - || case mb_ty of - Nothing -> False - Just ty -> isDictLikeTy ty - - ----------------------- -findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity --- This implements the fixpoint loop for arity analysis --- See Note [Arity analysis] -findRhsArity dflags bndr rhs old_arity - = go (rhsEtaExpandArity dflags init_cheap_app rhs) - -- 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 - 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 -> Arity - go cur_arity - | cur_arity <= old_arity = cur_arity - | new_arity == cur_arity = cur_arity - | otherwise = ASSERT( new_arity < cur_arity ) -#ifdef DEBUG - pprTrace "Exciting arity" - (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity - , ppr rhs]) -#endif - go new_arity - where - new_arity = rhsEtaExpandArity dflags cheap_app rhs - - cheap_app :: CheapAppFun - cheap_app fn n_val_args - | fn == bndr = n_val_args < cur_arity - | otherwise = isCheapApp fn n_val_args - --- ^ The Arity returned is the number of value args the --- expression can be applied to without doing much work -rhsEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity --- exprEtaExpandArity is used when eta expanding --- e ==> \xy -> e x y -rhsEtaExpandArity dflags cheap_app e - = case (arityType env e) of - ATop (os:oss) - | isOneShotInfo os || has_lam e -> 1 + length oss - -- Don't expand PAPs/thunks - -- Note [Eta expanding thunks] - | otherwise -> 0 - ATop [] -> 0 - ABot n -> n - where - env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app - , ae_ped_bot = gopt Opt_PedanticBottoms dflags } - - has_lam (Tick _ e) = has_lam e - has_lam (Lam b e) = isId b || has_lam e - has_lam _ = False -\end{code} - -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 Trac #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 exprIsCheap' 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. - -See Note [Dictionary-like types] in TcType.lhs for why we use -isDictLikeTy here rather than isDictTy - -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! - -\begin{code} -arityLam :: Id -> ArityType -> ArityType -arityLam id (ATop as) = ATop (idOneShotInfo 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 `min` n2) -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 -\end{code} - -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 barnches 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. - -\begin{code} ---------------------------- -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) - ABot n -> ABot (n `min` co_arity) - where - co_arity = length (typeArity (pSnd (coercionKind 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 - -- Trac #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 $ isNopSig strict_sig - , (ds, res) <- splitStrictSig strict_sig - , let arity = length ds - = if isBotRes 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 -\end{code} - - -%************************************************************************ -%* * - 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 alernative, 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 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" - -\begin{code} --- | @etaExpand n us e ty@ returns an expression with --- the same meaning as @e@, but with arity @n@. --- --- Given: --- --- > e' = etaExpand n us e ty --- --- We should have that: --- --- > ty = exprType e = exprType e' -etaExpand :: Arity -- ^ Result should have this number of value args - -> CoreExpr -- ^ Expression to expand - -> CoreExpr --- 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 - -- 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]) $ - etaInfoAbs etas (etaInfoApp subst' expr etas) - where - in_scope = mkInScopeSet (exprFreeVars expr) - (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr) - subst' = mkEmptySubst in_scope' - - -- Wrapper Unwrapper --------------- -data EtaInfo = EtaVar Var -- /\a. [], [] a - -- \x. [], [] x - | EtaCo Coercion -- [] |> co, [] |> (sym co) - -instance Outputable EtaInfo where - ppr (EtaVar v) = ptext (sLit "EtaVar") <+> ppr v - ppr (EtaCo co) = ptext (sLit "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 (CoreSubst.extendSubstWithVar subst v1 v2) e eis - -etaInfoApp subst (Cast e co1) eis - = etaInfoApp subst e (pushCoercion co' eis) - where - co' = CoreSubst.substCo subst co1 - -etaInfoApp subst (Case e b ty alts) eis - = Case (subst_expr subst e) b1 (mk_alts_ty (CoreSubst.substTy subst ty) eis) alts' - where - (subst1, b1) = substBndr subst b - alts' = map subst_alt alts - subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) - where - (subst2,bs') = substBndrs subst1 bs - - mk_alts_ty ty [] = ty - mk_alts_ty ty (EtaVar v : eis) = mk_alts_ty (applyTypeToArg ty (varToCoreExpr v)) eis - mk_alts_ty _ (EtaCo co : eis) = mk_alts_ty (pSnd (coercionKind co)) eis - -etaInfoApp subst (Let b e) eis - = Let b' (etaInfoApp subst' e eis) - where - (subst', b') = subst_bind subst b - -etaInfoApp subst (Tick t e) eis - = Tick (substTickish subst t) (etaInfoApp subst e eis) - -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 - --------------- -mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type - -> (InScopeSet, [EtaInfo]) - -- EtaInfo contains fresh variables, - -- not free in the incoming CoreExpr - -- Outgoing InScopeSet includes the EtaInfo vars - -- and the original free vars - -mkEtaWW orig_n orig_expr in_scope orig_ty - = go orig_n empty_subst orig_ty [] - where - empty_subst = TvSubst in_scope emptyTvSubstEnv - - go n subst ty eis -- See Note [exprArity invariant] - | n == 0 - = (getTvInScope subst, reverse eis) - - | Just (tv,ty') <- splitForAllTy_maybe ty - , let (subst', tv') = Type.substTyVarBndr subst tv - -- Avoid free vars of the original expression - = go n subst' ty' (EtaVar tv' : eis) - - | Just (arg_ty, res_ty) <- splitFunTy_maybe ty - , 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) - - | Just (co, ty') <- topNormaliseNewType_maybe ty - = -- 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) - go n subst ty' (EtaCo co : eis) - - | otherwise -- We have an expression of arity > 0, - -- but its type isn't a function. - = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr ) - (getTvInScope subst, reverse eis) - -- This *can* legitmately happen: - -- e.g. coerce Int (\x. x) Essentially the programmer is - -- playing fast and loose with types (Happy does this a lot). - -- So we simply decline to eta-expand. Otherwise we'd end up - -- with an explicit lambda having a non-function type - - --------------- --- Avoiding unnecessary substitution; use short-cutting versions - -subst_expr :: Subst -> CoreExpr -> CoreExpr -subst_expr = substExprSC (text "CoreArity:substExpr") - -subst_bind :: Subst -> CoreBind -> (Subst, CoreBind) -subst_bind = substBindSC - - --------------- -freshEtaId :: Int -> TvSubst -> Type -> (TvSubst, 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.substTy subst ty - eta_id' = uniqAway (getTvInScope subst) $ - mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty' - subst' = extendTvInScope subst eta_id' -\end{code} diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs new file mode 100644 index 0000000000..af475bab3f --- /dev/null +++ b/compiler/coreSyn/CoreFVs.hs @@ -0,0 +1,533 @@ +{- +(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 CoreFVs ( + -- * Free variables of expressions and binding groups + exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars + exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids + exprsFreeVars, -- [CoreExpr] -> VarSet + bindFreeVars, -- CoreBind -> VarSet + + -- * Selective free variables of expressions + InterestingVarFun, + exprSomeFreeVars, exprsSomeFreeVars, + + -- * Free variables of Rules, Vars and Ids + varTypeTyVars, + idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, + idRuleVars, idRuleRhsVars, stableUnfoldingVars, + ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, + ruleLhsOrphNames, ruleLhsFreeIds, + vectsFreeVars, + + -- * Core syntax tree annotation with free variables + CoreExprWithFVs, -- = AnnExpr Id VarSet + CoreBindWithFVs, -- = AnnBind Id VarSet + freeVars, -- CoreExpr -> CoreExprWithFVs + freeVarsOf -- CoreExprWithFVs -> IdSet + ) where + +#include "HsVersions.h" + +import CoreSyn +import Id +import IdInfo +import NameSet +import UniqFM +import Name +import VarSet +import Var +import TcType +import Coercion +import Maybes( orElse ) +import Util +import BasicTypes( Activation ) +import Outputable + +{- +************************************************************************ +* * +\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 +exprFreeVars :: CoreExpr -> VarSet +exprFreeVars = exprSomeFreeVars isLocalVar + +-- | 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 or type variables in several expressions +exprsFreeVars :: [CoreExpr] -> VarSet +exprsFreeVars = mapUnionVarSet exprFreeVars + +-- | Find all locally defined free Ids in a binding group +bindFreeVars :: CoreBind -> VarSet +bindFreeVars (NonRec b r) = rhs_fvs (b,r) isLocalVar emptyVarSet +bindFreeVars (Rec prs) = addBndrs (map fst prs) + (foldr (union . rhs_fvs) noVars prs) + isLocalVar emptyVarSet + +-- | Finds free variables in an expression selected by a predicate +exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> VarSet +exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet + +-- | Finds free variables in several expressions selected by a predicate +exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting + -> [CoreExpr] + -> VarSet +exprsSomeFreeVars fv_cand = mapUnionVarSet (exprSomeFreeVars fv_cand) + +-- | Predicate on possible free variables: returns @True@ iff the variable is interesting +type InterestingVarFun = Var -> Bool + +type FV = InterestingVarFun + -> VarSet -- Locally bound + -> VarSet -- Free vars + -- Return the vars that are both (a) interesting + -- and (b) not locally bound + -- See function keep_it + +keep_it :: InterestingVarFun -> VarSet -> Var -> Bool +keep_it fv_cand in_scope var + | var `elemVarSet` in_scope = False + | fv_cand var = True + | otherwise = False + +union :: FV -> FV -> FV +union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope + +noVars :: FV +noVars _ _ = emptyVarSet + +-- Comment about obselete 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 + +oneVar :: Id -> FV +oneVar var fv_cand in_scope + = ASSERT( isId var ) + if keep_it fv_cand in_scope var + then unitVarSet var + else emptyVarSet + +someVars :: VarSet -> FV +someVars vars fv_cand in_scope + = filterVarSet (keep_it fv_cand in_scope) vars + +addBndr :: CoreBndr -> FV -> FV +addBndr bndr fv fv_cand in_scope + = someVars (varTypeTyVars bndr) fv_cand in_scope + -- Include type varibles in the binder's type + -- (not just Ids; coercion variables too!) + `unionVarSet` fv fv_cand (in_scope `extendVarSet` bndr) + +addBndrs :: [CoreBndr] -> FV -> FV +addBndrs bndrs fv = foldr addBndr fv bndrs + +expr_fvs :: CoreExpr -> FV + +expr_fvs (Type ty) = someVars (tyVarsOfType ty) +expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co) +expr_fvs (Var var) = oneVar var +expr_fvs (Lit _) = noVars +expr_fvs (Tick t expr) = tickish_fvs t `union` expr_fvs expr +expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg +expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body) +expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyCoVarsOfCo co) + +expr_fvs (Case scrut bndr ty alts) + = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr + (foldr (union . alt_fvs) noVars alts) + where + alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) + +expr_fvs (Let (NonRec bndr rhs) body) + = rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body) + +expr_fvs (Let (Rec pairs) body) + = addBndrs (map fst pairs) + (foldr (union . rhs_fvs) (expr_fvs body) pairs) + +--------- +rhs_fvs :: (Id,CoreExpr) -> FV +rhs_fvs (bndr, rhs) = expr_fvs rhs `union` + someVars (bndrRuleAndUnfoldingVars bndr) + -- Treat any RULES as extra RHSs of the binding + +--------- +exprs_fvs :: [CoreExpr] -> FV +exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs + +tickish_fvs :: Tickish Id -> FV +tickish_fvs (Breakpoint _ ids) = someVars (mkVarSet ids) +tickish_fvs _ = noVars + +{- +************************************************************************ +* * +\section{Free names} +* * +************************************************************************ +-} + +-- | ruleLhsOrphNames is used when deciding whether +-- a rule is an orphan. In particular, suppose that T is defined in this +-- module; we want to avoid declaring that a rule like: +-- +-- > fromIntegral T = fromIntegral_T +-- +-- is an orphan. Of course it isn't, and declaring it an orphan would +-- make the whole module an orphan module, which is bad. +ruleLhsOrphNames :: CoreRule -> NameSet +ruleLhsOrphNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn +ruleLhsOrphNames (Rule { ru_fn = fn, ru_args = tpl_args }) + = extendNameSet (exprsOrphNames tpl_args) fn + -- No need to delete bndrs, because + -- exprsOrphNames finds only External 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 + +{- +************************************************************************ +* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +* * +************************************************************************ +-} + +-- | Those variables free in the right hand side of a rule +ruleRhsFreeVars :: CoreRule -> VarSet +ruleRhsFreeVars (BuiltinRule {}) = noFVs +ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) + = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet + -- See Note [Rule free var hack] + +-- | Those variables free in the both the left right hand sides of a rule +ruleFreeVars :: CoreRule -> VarSet +ruleFreeVars (BuiltinRule {}) = noFVs +ruleFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }) + = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet + -- See Note [Rule free var hack] + +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.lhs + = delFromUFM fvs fn -- Note [Rule free var hack] + where + fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet + 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 +ruleLhsFreeIds (BuiltinRule {}) = noFVs +ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args }) + = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet + +{- +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. +-} + +-- |Free variables of a vectorisation declaration +vectsFreeVars :: [CoreVect] -> VarSet +vectsFreeVars = mapUnionVarSet vectFreeVars + where + vectFreeVars (Vect _ rhs) = expr_fvs rhs isLocalId emptyVarSet + vectFreeVars (NoVect _) = noFVs + vectFreeVars (VectType _ _ _) = noFVs + vectFreeVars (VectClass _) = noFVs + vectFreeVars (VectInst _) = noFVs + -- this function is only concerned with values, not types + +{- +************************************************************************ +* * +\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. +-} + +-- | Every node in a binding group annotated with its +-- (non-global) free variables, both Ids and TyVars +type CoreBindWithFVs = AnnBind Id VarSet +-- | Every node in an expression annotated with its +-- (non-global) free variables, both Ids and TyVars +type CoreExprWithFVs = AnnExpr Id VarSet + +freeVarsOf :: CoreExprWithFVs -> IdSet +-- ^ Inverse function to 'freeVars' +freeVarsOf (free_vars, _) = free_vars + +noFVs :: VarSet +noFVs = emptyVarSet + +aFreeVar :: Var -> VarSet +aFreeVar = unitVarSet + +unionFVs :: VarSet -> VarSet -> VarSet +unionFVs = unionVarSet + +delBindersFV :: [Var] -> VarSet -> VarSet +delBindersFV bs fvs = foldr delBinderFV fvs bs + +delBinderFV :: Var -> VarSet -> VarSet +-- 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, +-- but *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.lhs: +-- errorIO (ST io) = case (errorIO# io) of +-- _ -> bottom +-- where +-- bottom = bottom -- Never evaluated + +delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b + -- Include coercion variables too! + +varTypeTyVars :: Var -> TyVarSet +-- Find the type/kind variables free in the type of the id/tyvar +varTypeTyVars var = tyVarsOfType (varType var) + +idFreeVars :: Id -> VarSet +-- Type variables, rule variables, and inline variables +idFreeVars id = ASSERT( isId id) + varTypeTyVars id `unionVarSet` + idRuleAndUnfoldingVars id + +bndrRuleAndUnfoldingVars ::Var -> VarSet +-- A 'let' can bind a type variable, and idRuleVars assumes +-- it's seeing an Id. This function tests first. +bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet + | otherwise = idRuleAndUnfoldingVars v + +idRuleAndUnfoldingVars :: Id -> VarSet +idRuleAndUnfoldingVars id = ASSERT( isId id) + idRuleVars id `unionVarSet` + idUnfoldingVars id + +idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars +idRuleVars id = ASSERT( isId id) specInfoFreeVars (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 = stableUnfoldingVars (realIdUnfolding id) `orElse` emptyVarSet + +stableUnfoldingVars :: Unfolding -> Maybe VarSet +stableUnfoldingVars unf + = case unf of + CoreUnfolding { uf_tmpl = rhs, uf_src = src } + | isStableSource src + -> Just (exprFreeVars rhs) + DFunUnfolding { df_bndrs = bndrs, df_args = args } + -> Just (exprs_fvs args isLocalVar (mkVarSet bndrs)) + -- DFuns are top level, so no fvs from types of bndrs + _other -> Nothing + +{- +************************************************************************ +* * +\subsection{Free variables (and types)} +* * +************************************************************************ +-} + +freeVars :: CoreExpr -> CoreExprWithFVs +-- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node +freeVars (Var v) + = (fvs, AnnVar v) + where + -- ToDo: insert motivating example for why we *need* + -- to include the idSpecVars in the FV list. + -- Actually [June 98] I don't think it's necessary + -- fvs = fvs_v `unionVarSet` idSpecVars v + + fvs | isLocalVar v = aFreeVar v + | otherwise = noFVs + +freeVars (Lit lit) = (noFVs, AnnLit lit) +freeVars (Lam b body) + = (b `delBinderFV` freeVarsOf body', AnnLam b body') + where + body' = freeVars body + +freeVars (App fun arg) + = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2) + where + fun2 = freeVars fun + arg2 = freeVars arg + +freeVars (Case scrut bndr ty alts) + = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty, + AnnCase scrut2 bndr ty alts2) + where + scrut2 = freeVars scrut + + (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts + alts_fvs = foldr unionFVs noFVs alts_fvs_s + + fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), + (con, args, rhs2)) + where + rhs2 = freeVars rhs + +freeVars (Let (NonRec binder rhs) body) + = (freeVarsOf rhs2 + `unionFVs` body_fvs + `unionFVs` bndrRuleAndUnfoldingVars binder, + -- Remember any rules; cf rhs_fvs above + AnnLet (AnnNonRec binder rhs2) body2) + where + rhs2 = freeVars rhs + body2 = freeVars body + body_fvs = binder `delBinderFV` freeVarsOf body2 + +freeVars (Let (Rec binds) body) + = (delBindersFV binders all_fvs, + AnnLet (AnnRec (binders `zip` rhss2)) body2) + where + (binders, rhss) = unzip binds + + rhss2 = map freeVars rhss + rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 + all_fvs = foldr (unionFVs . idRuleAndUnfoldingVars) rhs_body_fvs binders + -- The "delBinderFV" happens after adding the idSpecVars, + -- since the latter may add some of the binders as fvs + + body2 = freeVars body + body_fvs = freeVarsOf body2 + +freeVars (Cast expr co) + = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co)) + where + expr2 = freeVars expr + cfvs = tyCoVarsOfCo co + +freeVars (Tick tickish expr) + = (tickishFVs tickish `unionFVs` freeVarsOf expr2, AnnTick tickish expr2) + where + expr2 = freeVars expr + tickishFVs (Breakpoint _ ids) = mkVarSet ids + tickishFVs _ = emptyVarSet + +freeVars (Type ty) = (tyVarsOfType ty, AnnType ty) + +freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co) diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs deleted file mode 100644 index fc804d7c6e..0000000000 --- a/compiler/coreSyn/CoreFVs.lhs +++ /dev/null @@ -1,545 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -Taken quite directly from the Peyton Jones/Lester paper. - -\begin{code} -{-# LANGUAGE CPP #-} - --- | A module concerned with finding the free variables of an expression. -module CoreFVs ( - -- * Free variables of expressions and binding groups - exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars - exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids - exprsFreeVars, -- [CoreExpr] -> VarSet - bindFreeVars, -- CoreBind -> VarSet - - -- * Selective free variables of expressions - InterestingVarFun, - exprSomeFreeVars, exprsSomeFreeVars, - - -- * Free variables of Rules, Vars and Ids - varTypeTyVars, - idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, - idRuleVars, idRuleRhsVars, stableUnfoldingVars, - ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, - ruleLhsOrphNames, ruleLhsFreeIds, - vectsFreeVars, - - -- * Core syntax tree annotation with free variables - CoreExprWithFVs, -- = AnnExpr Id VarSet - CoreBindWithFVs, -- = AnnBind Id VarSet - freeVars, -- CoreExpr -> CoreExprWithFVs - freeVarsOf -- CoreExprWithFVs -> IdSet - ) where - -#include "HsVersions.h" - -import CoreSyn -import Id -import IdInfo -import NameSet -import UniqFM -import Name -import VarSet -import Var -import TcType -import Coercion -import Maybes( orElse ) -import Util -import BasicTypes( Activation ) -import Outputable -\end{code} - - -%************************************************************************ -%* * -\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. - -\begin{code} --- | Find all locally-defined free Ids or type variables in an expression -exprFreeVars :: CoreExpr -> VarSet -exprFreeVars = exprSomeFreeVars isLocalVar - --- | 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 or type variables in several expressions -exprsFreeVars :: [CoreExpr] -> VarSet -exprsFreeVars = mapUnionVarSet exprFreeVars - --- | Find all locally defined free Ids in a binding group -bindFreeVars :: CoreBind -> VarSet -bindFreeVars (NonRec b r) = rhs_fvs (b,r) isLocalVar emptyVarSet -bindFreeVars (Rec prs) = addBndrs (map fst prs) - (foldr (union . rhs_fvs) noVars prs) - isLocalVar emptyVarSet - --- | Finds free variables in an expression selected by a predicate -exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting - -> CoreExpr - -> VarSet -exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet - --- | Finds free variables in several expressions selected by a predicate -exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting - -> [CoreExpr] - -> VarSet -exprsSomeFreeVars fv_cand = mapUnionVarSet (exprSomeFreeVars fv_cand) - --- | Predicate on possible free variables: returns @True@ iff the variable is interesting -type InterestingVarFun = Var -> Bool -\end{code} - - -\begin{code} -type FV = InterestingVarFun - -> VarSet -- Locally bound - -> VarSet -- Free vars - -- Return the vars that are both (a) interesting - -- and (b) not locally bound - -- See function keep_it - -keep_it :: InterestingVarFun -> VarSet -> Var -> Bool -keep_it fv_cand in_scope var - | var `elemVarSet` in_scope = False - | fv_cand var = True - | otherwise = False - -union :: FV -> FV -> FV -union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope - -noVars :: FV -noVars _ _ = emptyVarSet - --- Comment about obselete 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 - -oneVar :: Id -> FV -oneVar var fv_cand in_scope - = ASSERT( isId var ) - if keep_it fv_cand in_scope var - then unitVarSet var - else emptyVarSet - -someVars :: VarSet -> FV -someVars vars fv_cand in_scope - = filterVarSet (keep_it fv_cand in_scope) vars - -addBndr :: CoreBndr -> FV -> FV -addBndr bndr fv fv_cand in_scope - = someVars (varTypeTyVars bndr) fv_cand in_scope - -- Include type varibles in the binder's type - -- (not just Ids; coercion variables too!) - `unionVarSet` fv fv_cand (in_scope `extendVarSet` bndr) - -addBndrs :: [CoreBndr] -> FV -> FV -addBndrs bndrs fv = foldr addBndr fv bndrs -\end{code} - - -\begin{code} -expr_fvs :: CoreExpr -> FV - -expr_fvs (Type ty) = someVars (tyVarsOfType ty) -expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co) -expr_fvs (Var var) = oneVar var -expr_fvs (Lit _) = noVars -expr_fvs (Tick t expr) = tickish_fvs t `union` expr_fvs expr -expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg -expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body) -expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyCoVarsOfCo co) - -expr_fvs (Case scrut bndr ty alts) - = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr - (foldr (union . alt_fvs) noVars alts) - where - alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) - -expr_fvs (Let (NonRec bndr rhs) body) - = rhs_fvs (bndr, rhs) `union` addBndr bndr (expr_fvs body) - -expr_fvs (Let (Rec pairs) body) - = addBndrs (map fst pairs) - (foldr (union . rhs_fvs) (expr_fvs body) pairs) - ---------- -rhs_fvs :: (Id,CoreExpr) -> FV -rhs_fvs (bndr, rhs) = expr_fvs rhs `union` - someVars (bndrRuleAndUnfoldingVars bndr) - -- Treat any RULES as extra RHSs of the binding - ---------- -exprs_fvs :: [CoreExpr] -> FV -exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs - -tickish_fvs :: Tickish Id -> FV -tickish_fvs (Breakpoint _ ids) = someVars (mkVarSet ids) -tickish_fvs _ = noVars -\end{code} - - -%************************************************************************ -%* * -\section{Free names} -%* * -%************************************************************************ - -\begin{code} --- | ruleLhsOrphNames is used when deciding whether --- a rule is an orphan. In particular, suppose that T is defined in this --- module; we want to avoid declaring that a rule like: --- --- > fromIntegral T = fromIntegral_T --- --- is an orphan. Of course it isn't, and declaring it an orphan would --- make the whole module an orphan module, which is bad. -ruleLhsOrphNames :: CoreRule -> NameSet -ruleLhsOrphNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn -ruleLhsOrphNames (Rule { ru_fn = fn, ru_args = tpl_args }) - = extendNameSet (exprsOrphNames tpl_args) fn - -- No need to delete bndrs, because - -- exprsOrphNames finds only External 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 -\end{code} - -%************************************************************************ -%* * -\section[freevars-everywhere]{Attaching free variables to every sub-expression} -%* * -%************************************************************************ - -\begin{code} --- | Those variables free in the right hand side of a rule -ruleRhsFreeVars :: CoreRule -> VarSet -ruleRhsFreeVars (BuiltinRule {}) = noFVs -ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) - = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet - -- See Note [Rule free var hack] - --- | Those variables free in the both the left right hand sides of a rule -ruleFreeVars :: CoreRule -> VarSet -ruleFreeVars (BuiltinRule {}) = noFVs -ruleFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }) - = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet - -- See Note [Rule free var hack] - -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.lhs - = delFromUFM fvs fn -- Note [Rule free var hack] - where - fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet - 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 -ruleLhsFreeIds (BuiltinRule {}) = noFVs -ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args }) - = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet -\end{code} - -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. - -\begin{code} --- |Free variables of a vectorisation declaration -vectsFreeVars :: [CoreVect] -> VarSet -vectsFreeVars = mapUnionVarSet vectFreeVars - where - vectFreeVars (Vect _ rhs) = expr_fvs rhs isLocalId emptyVarSet - vectFreeVars (NoVect _) = noFVs - vectFreeVars (VectType _ _ _) = noFVs - vectFreeVars (VectClass _) = noFVs - vectFreeVars (VectInst _) = noFVs - -- this function is only concerned with values, not types -\end{code} - - -%************************************************************************ -%* * -\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. - -\begin{code} --- | Every node in a binding group annotated with its --- (non-global) free variables, both Ids and TyVars -type CoreBindWithFVs = AnnBind Id VarSet --- | Every node in an expression annotated with its --- (non-global) free variables, both Ids and TyVars -type CoreExprWithFVs = AnnExpr Id VarSet - -freeVarsOf :: CoreExprWithFVs -> IdSet --- ^ Inverse function to 'freeVars' -freeVarsOf (free_vars, _) = free_vars - -noFVs :: VarSet -noFVs = emptyVarSet - -aFreeVar :: Var -> VarSet -aFreeVar = unitVarSet - -unionFVs :: VarSet -> VarSet -> VarSet -unionFVs = unionVarSet - -delBindersFV :: [Var] -> VarSet -> VarSet -delBindersFV bs fvs = foldr delBinderFV fvs bs - -delBinderFV :: Var -> VarSet -> VarSet --- 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, --- but *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.lhs: --- errorIO (ST io) = case (errorIO# io) of --- _ -> bottom --- where --- bottom = bottom -- Never evaluated - -delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b - -- Include coercion variables too! - -varTypeTyVars :: Var -> TyVarSet --- Find the type/kind variables free in the type of the id/tyvar -varTypeTyVars var = tyVarsOfType (varType var) - -idFreeVars :: Id -> VarSet --- Type variables, rule variables, and inline variables -idFreeVars id = ASSERT( isId id) - varTypeTyVars id `unionVarSet` - idRuleAndUnfoldingVars id - -bndrRuleAndUnfoldingVars ::Var -> VarSet --- A 'let' can bind a type variable, and idRuleVars assumes --- it's seeing an Id. This function tests first. -bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet - | otherwise = idRuleAndUnfoldingVars v - -idRuleAndUnfoldingVars :: Id -> VarSet -idRuleAndUnfoldingVars id = ASSERT( isId id) - idRuleVars id `unionVarSet` - idUnfoldingVars id - -idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars -idRuleVars id = ASSERT( isId id) specInfoFreeVars (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 = stableUnfoldingVars (realIdUnfolding id) `orElse` emptyVarSet - -stableUnfoldingVars :: Unfolding -> Maybe VarSet -stableUnfoldingVars unf - = case unf of - CoreUnfolding { uf_tmpl = rhs, uf_src = src } - | isStableSource src - -> Just (exprFreeVars rhs) - DFunUnfolding { df_bndrs = bndrs, df_args = args } - -> Just (exprs_fvs args isLocalVar (mkVarSet bndrs)) - -- DFuns are top level, so no fvs from types of bndrs - _other -> Nothing -\end{code} - - -%************************************************************************ -%* * -\subsection{Free variables (and types)} -%* * -%************************************************************************ - -\begin{code} -freeVars :: CoreExpr -> CoreExprWithFVs --- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node -freeVars (Var v) - = (fvs, AnnVar v) - where - -- ToDo: insert motivating example for why we *need* - -- to include the idSpecVars in the FV list. - -- Actually [June 98] I don't think it's necessary - -- fvs = fvs_v `unionVarSet` idSpecVars v - - fvs | isLocalVar v = aFreeVar v - | otherwise = noFVs - -freeVars (Lit lit) = (noFVs, AnnLit lit) -freeVars (Lam b body) - = (b `delBinderFV` freeVarsOf body', AnnLam b body') - where - body' = freeVars body - -freeVars (App fun arg) - = (freeVarsOf fun2 `unionFVs` freeVarsOf arg2, AnnApp fun2 arg2) - where - fun2 = freeVars fun - arg2 = freeVars arg - -freeVars (Case scrut bndr ty alts) - = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty, - AnnCase scrut2 bndr ty alts2) - where - scrut2 = freeVars scrut - - (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts - alts_fvs = foldr unionFVs noFVs alts_fvs_s - - fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), - (con, args, rhs2)) - where - rhs2 = freeVars rhs - -freeVars (Let (NonRec binder rhs) body) - = (freeVarsOf rhs2 - `unionFVs` body_fvs - `unionFVs` bndrRuleAndUnfoldingVars binder, - -- Remember any rules; cf rhs_fvs above - AnnLet (AnnNonRec binder rhs2) body2) - where - rhs2 = freeVars rhs - body2 = freeVars body - body_fvs = binder `delBinderFV` freeVarsOf body2 - -freeVars (Let (Rec binds) body) - = (delBindersFV binders all_fvs, - AnnLet (AnnRec (binders `zip` rhss2)) body2) - where - (binders, rhss) = unzip binds - - rhss2 = map freeVars rhss - rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 - all_fvs = foldr (unionFVs . idRuleAndUnfoldingVars) rhs_body_fvs binders - -- The "delBinderFV" happens after adding the idSpecVars, - -- since the latter may add some of the binders as fvs - - body2 = freeVars body - body_fvs = freeVarsOf body2 - -freeVars (Cast expr co) - = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co)) - where - expr2 = freeVars expr - cfvs = tyCoVarsOfCo co - -freeVars (Tick tickish expr) - = (tickishFVs tickish `unionFVs` freeVarsOf expr2, AnnTick tickish expr2) - where - expr2 = freeVars expr - tickishFVs (Breakpoint _ ids) = mkVarSet ids - tickishFVs _ = emptyVarSet - -freeVars (Type ty) = (tyVarsOfType ty, AnnType ty) - -freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co) -\end{code} - diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs new file mode 100644 index 0000000000..26519cc928 --- /dev/null +++ b/compiler/coreSyn/CoreLint.hs @@ -0,0 +1,1442 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +A ``lint'' pass to check for Core correctness +-} + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fprof-auto #-} + +module CoreLint ( lintCoreBindings, lintUnfolding, lintExpr ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreFVs +import CoreUtils +import Bag +import Literal +import DataCon +import TysWiredIn +import TysPrim +import Var +import VarEnv +import VarSet +import Name +import Id +import PprCore +import ErrUtils +import Coercion +import SrcLoc +import Kind +import Type +import TypeRep +import TyCon +import CoAxiom +import BasicTypes +import StaticFlags +import ListSetOps +import PrelNames +import Outputable +import FastString +import Util +import OptCoercion ( checkAxInstCo ) +import Control.Monad +import MonadUtils +import Data.Maybe +import Pair + +{- +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 ghc.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. + +************************************************************************ +* * +\subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface} +* * +************************************************************************ + +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 + +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 type lets] +~~~~~~~~~~~~~~~~~~~~~~~~ +In the desugarer, it's very very convenient to be able to say (in effect) + let a = Type Int in +That is, use a type let. See Note [Type let] in CoreSyn. + +However, when linting 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 functin + lintInTy :: Type -> LintM Type +returns a substituted type; that's the only reason it returns anything. + +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 TvSubst we are carrying down), and when we +find an occurrence of an Id, we fetch it from the in-scope set. +-} + +lintCoreBindings :: [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 local_in_scope binds + = initL $ + addLoc TopLevelBindings $ + addInScopeVars local_in_scope $ + addInScopeVars 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 + 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} +* * +************************************************************************ + +We use this to check all unfoldings that come in from interfaces +(it is very painful to catch errors otherwise): +-} + +lintUnfolding :: SrcLoc + -> [Var] -- Treat these as in scope + -> CoreExpr + -> Maybe MsgDoc -- Nothing => OK + +lintUnfolding locn vars expr + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $ + addInScopeVars vars $ + lintCoreExpr expr) + +lintExpr :: [Var] -- Treat these as in scope + -> CoreExpr + -> Maybe MsgDoc -- Nothing => OK + +lintExpr vars expr + | isEmptyBag errs = Nothing + | otherwise = Just (pprMessageBag errs) + where + (_warns, errs) = initL (addLoc TopLevelBindings $ + addInScopeVars vars $ + 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 <- lintCoreExpr rhs + ; lintBinder binder -- Check match to RHS type + ; binder_ty <- applySubstTy binder_ty + ; checkTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) ty) + + -- Check the let/app invariant + -- See Note [CoreSyn let/app invariant] in CoreSyn + ; checkL (not (isUnLiftedType binder_ty) + || (isNonRec rec_flag && exprOkForSpeculation rhs)) + (mkRhsPrimMsg binder rhs) + + -- Check that if the binder is top-level or recursive, it's not demanded + ; checkL (not (isStrictId binder) + || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))) + (mkStrictMsg binder) + + -- Check that if the binder is local, it is not marked as exported + ; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag) + (mkNonTopExportedMsg binder) + + -- Check that if the binder is local, it does not have an external name + ; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag) + (mkNonTopExternalNameMsg binder) + + -- Check whether binder's specialisations contain any out-of-scope variables + ; mapM_ (checkBndrIdInScope binder) bndr_vars + + ; when (isStrongLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder)) + (addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder)) + -- Only non-rule loop breakers inhibit inlining + + -- Check whether arity and demand type are consistent (only if demand analysis + -- already happened) + -- + -- Note (Apr 2014): this is actually ok. See Note [Demand analysis for trivial right-hand sides] + -- in DmdAnal. After eta-expansion in CorePrep the rhs is no longer trivial. + -- ; let dmdTy = idStrictness binder + -- ; checkL (case dmdTy of + -- StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs) + -- (mkArityMsg 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. + where + binder_ty = idType binder + bndr_vars = varSetElems (idFreeVars binder) + + -- If you edit this function, you may need to update the GHC formalism + -- See Note [GHC Formalism] + lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) + | otherwise = return () + +lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () +lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + | isStableSource src + = do { ty <- lintCoreExpr rhs + ; checkTys bndr_ty ty (mkRhsMsg bndr (ptext (sLit "unfolding")) ty) } +lintIdUnfolding _ _ _ + = return () -- We could check more + +{- +************************************************************************ +* * +\subsection[lintCoreExpr]{lintCoreExpr} +* * +************************************************************************ +-} + +--type InKind = Kind -- Substitution not yet applied +type InType = Type +type InCoercion = Coercion +type InVar = Var +type InTyVar = TyVar + +type OutKind = Kind -- Substitution has been applied to this, + -- but has not been linted yet +type LintedKind = Kind -- Substitution applied, and type is linted + +type OutType = Type -- Substitution has been applied to this, + -- but has not been linted yet + +type LintedType = Type -- Substitution applied, and type is linted + +type OutCoercion = Coercion +type OutVar = Var +type OutTyVar = TyVar + +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) + = do { checkL (not (var == oneTupleDataConId)) + (ptext (sLit "Illegal one-tuple")) + + ; checkL (isId var && not (isCoVar var)) + (ptext (sLit "Non term variable") <+> ppr var) + + ; checkDeadIdOcc var + ; var' <- lookupIdInScope var + ; return (idType var') } + +lintCoreExpr (Lit lit) + = return (literalType lit) + +lintCoreExpr (Cast expr co) + = do { expr_ty <- lintCoreExpr expr + ; co' <- applySubstCo co + ; (_, from_ty, to_ty, r) <- lintCoercion co' + ; checkRole co' Representational r + ; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) + ; return to_ty } + +lintCoreExpr (Tick (Breakpoint _ ids) expr) + = do forM_ ids $ \id -> do + checkDeadIdOcc id + lookupIdInScope id + lintCoreExpr expr + +lintCoreExpr (Tick _other_tickish expr) + = lintCoreExpr expr + +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) $ checkTyKind 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]) + (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) } + + | otherwise + = failWithL (mkLetErr bndr rhs) -- Not quite accurate + +lintCoreExpr (Let (Rec pairs) body) + = lintAndScopeIds bndrs $ \_ -> + do { checkL (null dups) (dupVars dups) + ; 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 <- lintCoreExpr fun + ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args } + where + (fun, args) = collectArgs e + +lintCoreExpr (Lam var expr) + = addLoc (LambdaBodyOf var) $ + lintBinder var $ \ var' -> + do { body_ty <- lintCoreExpr expr + ; if isId var' then + return (mkFunTy (idType var') body_ty) + else + return (mkForAllTy var' body_ty) + } + -- The applySubstTy is needed to apply the subst to var + +lintCoreExpr e@(Case scrut var alt_ty alts) = + -- Check the scrutinee + do { scrut_ty <- lintCoreExpr scrut + ; alt_ty <- lintInTy alt_ty + ; var_ty <- lintInTy (idType var) + + ; case tyConAppTyCon_maybe (idType var) of + Just tycon + | debugIsOn && + isAlgTyCon tycon && + not (isFamilyTyCon tycon || isAbstractTyCon tycon) && + null (tyConDataCons tycon) -> + 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 <- getTvSubst + ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) + + ; lintAndScopeId var $ \_ -> + do { -- Check the alternatives + mapM_ (lintCoreAlt scrut_ty alt_ty) alts + ; checkCaseAlts e scrut_ty alts + ; return alt_ty } } + +-- This case can't happen; linting types in expressions gets routed through +-- lintCoreArgs +lintCoreExpr (Type ty) + = pprPanic "lintCoreExpr" (ppr ty) + +lintCoreExpr (Coercion co) + = do { (_kind, ty1, ty2, role) <- lintInCo co + ; return (mkCoercionType role ty1 ty2) } + +{- +Note [Kind instantiation in coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following coercion axiom: + ax_co [(k_ag :: BOX), (f_aa :: k_ag -> Constraint)] :: T k_ag f_aa ~ f_aa + +Consider the following instantiation: + ax_co <* -> *> + +We need to split the co_ax_tvs into kind and type variables in order +to find out the coercion kind instantiations. Those can only be Refl +since we don't have kind coercions. This is just a way to represent +kind instantiation. + +We use the number of kind variables to know how to split the coercions +instantiations between kind coercions and type coercions. We lint the +kind coercions and produce the following substitution which is to be +applied in the type variables: + k_ag ~~> * -> * + +************************************************************************ +* * +\subsection[lintCoreArgs]{lintCoreArgs} +* * +************************************************************************ + +The basic version of these functions checks that the argument is a +subtype of the required type, as one would expect. +-} + +lintCoreArg :: OutType -> CoreArg -> LintM OutType +lintCoreArg fun_ty (Type arg_ty) + = do { arg_ty' <- applySubstTy arg_ty + ; lintTyApp fun_ty arg_ty' } + +lintCoreArg fun_ty arg + = do { arg_ty <- lintCoreExpr arg + ; 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 [] + = checkTys 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 (tyvar,body_ty) <- splitForAllTy_maybe fun_ty + , isTyVar tyvar + = do { checkTyKind tyvar arg_ty + ; return (substTyWith [tyvar] [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 { checkTys arg arg_ty err1 + ; return res } + | otherwise + = failWithL err2 + where + err1 = mkAppMsg fun_ty arg_ty arg + err2 = mkNonFunAppMsg fun_ty arg_ty arg + +checkTyKind :: 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] +checkTyKind tyvar arg_ty + | isSuperKind tyvar_kind -- kind forall + = lintKind arg_ty + -- Arg type might be boxed for a function with an uncommitted + -- tyvar; notably this is used so that we can give + -- error :: forall a:*. String -> a + -- and then apply it to both boxed and unboxed types. + | otherwise -- type forall + = do { arg_kind <- lintType arg_ty + ; unless (arg_kind `isSubKind` tyvar_kind) + (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "xx" <+> ppr arg_kind))) } + where + tyvar_kind = tyVarKind tyvar + +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 + (ptext (sLit "Occurrence of a dead Id") <+> ppr id) } + | otherwise + = return () + +{- +************************************************************************ +* * +\subsection[lintCoreAlts]{lintCoreAlts} +* * +************************************************************************ +-} + +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 simplifer correctly eliminates case that can't +-- possibly match. + +checkCaseAlts e ty alts = + do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) + ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) + + -- 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 CoreSyn) 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 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 + +checkAltExpr :: CoreExpr -> OutType -> LintM () +checkAltExpr expr ann_ty + = do { actual_ty <- lintCoreExpr expr + ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) } + +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 { checkL (null args) (mkDefaultArgsMsg args) + ; checkAltExpr rhs alt_ty } + +lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) + | litIsLifted lit + = failWithL integerScrutinisedMsg + | otherwise + = do { checkL (null args) (mkDefaultArgsMsg args) + ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) + ; checkAltExpr 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 + checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con) + ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys + + -- And now bring the new binders into scope + ; lintBinders args $ \ args' -> do + { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args') + ; checkAltExpr 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 :: [Var] -> ([Var] -> LintM a) -> LintM a +lintBinders [] linterF = linterF [] +lintBinders (var:vars) linterF = lintBinder var $ \var' -> + lintBinders vars $ \ vars' -> + linterF (var':vars') + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintBinder :: Var -> (Var -> LintM a) -> LintM a +lintBinder var linterF + | isId var = lintIdBndr var linterF + | otherwise = lintTyBndr var linterF + +lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a +lintTyBndr tv thing_inside + = do { subst <- getTvSubst + ; let (subst', tv') = Type.substTyVarBndr subst tv + ; lintTyBndrKind tv' + ; updateTvSubst subst' (thing_inside tv') } + +lintIdBndr :: Id -> (Id -> 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 id linterF + = do { lintAndScopeId id $ \id' -> linterF id' } + +lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a +lintAndScopeIds ids linterF + = go ids + where + go [] = linterF [] + go (id:ids) = lintAndScopeId id $ \id -> + lintAndScopeIds ids $ \ids -> + linterF (id:ids) + +lintAndScopeId :: InVar -> (OutVar -> LintM a) -> LintM a +lintAndScopeId id linterF + = do { ty <- lintInTy (idType id) + ; let id' = setIdType id ty + ; addInScopeVar id' $ (linterF id') } + +{- +************************************************************************ +* * + Types and kinds +* * +************************************************************************ + +We have a single linter for types and kinds. That is convenient +because sometimes it's not clear whether the thing we are looking +at is a type or a kind. +-} + +lintInTy :: InType -> LintM LintedType +-- 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' + ; return ty' } + +------------------- +lintTyBndrKind :: OutTyVar -> LintM () +-- Handles both type and kind foralls. +lintTyBndrKind tv = lintKind (tyVarKind tv) + +------------------- +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 { checkTyCoVarInScope tv + ; return (tyVarKind tv) } + -- We checked its kind when we added it to the envt + +lintType ty@(AppTy t1 t2) + = do { k1 <- lintType t1 + ; k2 <- lintType t2 + ; lint_ty_app ty k1 [(t2,k2)] } + +lintType ty@(FunTy t1 t2) -- (->) has two different rules, for types and kinds + = do { k1 <- lintType t1 + ; k2 <- lintType t2 + ; lintArrow (ptext (sLit "type or kind") <+> quotes (ppr ty)) k1 k2 } + +lintType ty@(TyConApp tc tys) + | Just ty' <- coreView ty + = lintType ty' -- Expand type synonyms, so that we do not bogusly complain + -- about un-saturated type synonyms + + | isUnLiftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + -- See Note [The kind invariant] in TypeRep + -- Also type synonyms and type families + , length tys < tyConArity tc + = failWithL (hang (ptext (sLit "Un-saturated type application")) 2 (ppr ty)) + + | otherwise + = do { ks <- mapM lintType tys + ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } + +lintType (ForAllTy tv ty) + = do { lintTyBndrKind tv + ; addInScopeVar tv (lintType ty) } + +lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) + +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 (isSuperKind sk) + (addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k) + 2 (ptext (sLit "has kind:") <+> ppr sk))) } + +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 + | isSuperKind k1 + = return superKind + | otherwise + = do { unless (okArrowArgKind k1) (addErrL (msg (ptext (sLit "argument")) k1)) + ; unless (okArrowResultKind k2) (addErrL (msg (ptext (sLit "result")) k2)) + ; return liftedTypeKind } + where + msg ar k + = vcat [ hang (ptext (sLit "Ill-kinded") <+> ar) + 2 (ptext (sLit "in") <+> what) + , what <+> ptext (sLit "kind:") <+> ppr k ] + +lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind +lint_ty_app ty k tys + = lint_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys + +---------------- +lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind +lint_co_app ty k tys + = lint_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys + +---------------- +lintTyLit :: TyLit -> LintM () +lintTyLit (NumTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = ptext (sLit "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 + = foldlM go_app kfn kas + where + fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc + , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) + , nest 2 (ptext (sLit "Arg kinds =") <+> ppr kas) ] + + go_app kfn ka + | Just kfn' <- coreView kfn + = go_app kfn' ka + + go_app (FunTy kfa kfb) (_,ka) + = do { unless (ka `isSubKind` kfa) (addErrL fail_msg) + ; return kfb } + + go_app (ForAllTy kv kfn) (ta,ka) + = do { unless (ka `isSubKind` tyVarKind kv) (addErrL fail_msg) + ; return (substKiWith [kv] [ta] kfn) } + + go_app _ _ = failWithL fail_msg + +{- +************************************************************************ +* * + Linting coercions +* * +************************************************************************ +-} + +lintInCo :: InCoercion -> LintM (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' } + +lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType, Role) +-- Check the kind of a coercion term, returning the kind +-- Post-condition: the returned OutTypes are lint-free +-- and have the same kind as each other + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoercion (Refl r ty) + = do { k <- lintType ty + ; return (k, ty, ty, r) } + +lintCoercion co@(TyConAppCo r tc cos) + | tc `hasKey` funTyConKey + , [co1,co2] <- cos + = do { (k1,s1,t1,r1) <- lintCoercion co1 + ; (k2,s2,t2,r2) <- lintCoercion co2 + ; rk <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2 + ; checkRole co1 r r1 + ; checkRole co2 r r2 + ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2, r) } + + | Just {} <- synTyConDefn_maybe tc + = failWithL (ptext (sLit "Synonym in TyConAppCo:") <+> ppr co) + + | otherwise + = do { (ks,ss,ts,rs) <- mapAndUnzip4M lintCoercion cos + ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks) + ; _ <- zipWith3M checkRole cos (tyConRolesX r tc) rs + ; return (rk, mkTyConApp tc ss, mkTyConApp tc ts, r) } + +lintCoercion co@(AppCo co1 co2) + = do { (k1,s1,t1,r1) <- lintCoercion co1 + ; (k2,s2,t2,r2) <- lintCoercion co2 + ; rk <- lint_co_app co k1 [(s2,k2)] + ; if r1 == Phantom + then checkL (r2 == Phantom || r2 == Nominal) + (ptext (sLit "Second argument in AppCo cannot be R:") $$ + ppr co) + else checkRole co Nominal r2 + ; return (rk, mkAppTy s1 s2, mkAppTy t1 t2, r1) } + +lintCoercion (ForAllCo tv co) + = do { lintTyBndrKind tv + ; (k, s, t, r) <- addInScopeVar tv (lintCoercion co) + ; return (k, mkForAllTy tv s, mkForAllTy tv t, r) } + +lintCoercion (CoVarCo cv) + | not (isCoVar cv) + = failWithL (hang (ptext (sLit "Bad CoVarCo:") <+> ppr cv) + 2 (ptext (sLit "With offending type:") <+> ppr (varType cv))) + | otherwise + = do { checkTyCoVarInScope cv + ; cv' <- lookupIdInScope cv + ; let (s,t) = coVarKind cv' + k = typeKind s + r = coVarRole cv' + ; when (isSuperKind k) $ + do { checkL (r == Nominal) (hang (ptext (sLit "Non-nominal kind equality")) + 2 (ppr cv)) + ; checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality")) + 2 (ppr cv)) } + ; return (k, s, t, r) } + +lintCoercion (UnivCo r ty1 ty2) + = do { k1 <- lintType ty1 + ; _k2 <- lintType ty2 +-- ; unless (k1 `eqKind` k2) $ +-- failWithL (hang (ptext (sLit "Unsafe coercion changes kind")) +-- 2 (ppr co)) + ; return (k1, ty1, ty2, r) } + +lintCoercion (SymCo co) + = do { (k, ty1, ty2, r) <- lintCoercion co + ; return (k, ty2, ty1, r) } + +lintCoercion co@(TransCo co1 co2) + = do { (k1, ty1a, ty1b, r1) <- lintCoercion co1 + ; (_, ty2a, ty2b, r2) <- lintCoercion co2 + ; checkL (ty1b `eqType` ty2a) + (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) + 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) + ; checkRole co r1 r2 + ; return (k1, ty1a, ty2b, r1) } + +lintCoercion the_co@(NthCo n co) + = do { (_,s,t,r) <- lintCoercion co + ; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of + (Just (tc_s, tys_s), Just (tc_t, tys_t)) + | tc_s == tc_t + , tys_s `equalLength` tys_t + , n < length tys_s + -> return (ks, ts, tt, tr) + where + ts = getNth tys_s n + tt = getNth tys_t n + tr = nthRole r tc_s n + ks = typeKind ts + + _ -> failWithL (hang (ptext (sLit "Bad getNth:")) + 2 (ppr the_co $$ ppr s $$ ppr t)) } + +lintCoercion the_co@(LRCo lr co) + = do { (_,s,t,r) <- lintCoercion co + ; checkRole co Nominal r + ; case (splitAppTy_maybe s, splitAppTy_maybe t) of + (Just s_pr, Just t_pr) + -> return (k, s_pick, t_pick, Nominal) + where + s_pick = pickLR lr s_pr + t_pick = pickLR lr t_pr + k = typeKind s_pick + + _ -> failWithL (hang (ptext (sLit "Bad LRCo:")) + 2 (ppr the_co $$ ppr s $$ ppr t)) } + +lintCoercion (InstCo co arg_ty) + = do { (k,s,t,r) <- lintCoercion co + ; arg_kind <- lintType arg_ty + ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of + (Just (tv1,ty1), Just (tv2,ty2)) + | arg_kind `isSubKind` tyVarKind tv1 + -> return (k, substTyWith [tv1] [arg_ty] ty1, + substTyWith [tv2] [arg_ty] ty2, r) + | otherwise + -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) + _ -> failWithL (ptext (sLit "Bad argument of inst")) } + +lintCoercion co@(AxiomInstCo con ind cos) + = do { unless (0 <= ind && ind < brListLength (coAxiomBranches con)) + (bad_ax (ptext (sLit "index out of range"))) + -- See Note [Kind instantiation in coercions] + ; let CoAxBranch { cab_tvs = ktvs + , cab_roles = roles + , cab_lhs = lhs + , cab_rhs = rhs } = coAxiomNthBranch con ind + ; unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths"))) + ; in_scope <- getInScope + ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv + ; (subst_l, subst_r) <- foldlM check_ki + (empty_subst, empty_subst) + (zip3 ktvs roles cos) + ; let lhs' = Type.substTys subst_l lhs + rhs' = Type.substTy subst_r rhs + ; case checkAxInstCo co of + Just bad_branch -> bad_ax $ ptext (sLit "inconsistent with") <+> (pprCoAxBranch (coAxiomTyCon con) bad_branch) + Nothing -> return () + ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs', coAxiomRole con) } + where + bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what) + 2 (ppr co)) + + check_ki (subst_l, subst_r) (ktv, role, co) + = do { (k, t1, t2, r) <- lintCoercion co + ; checkRole co role r + ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv) + -- Using subst_l is ok, because subst_l and subst_r + -- must agree on kind equalities + ; unless (k `isSubKind` ktv_kind) + (bad_ax (ptext (sLit "check_ki2") <+> vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] )) + ; return (Type.extendTvSubst subst_l ktv t1, + Type.extendTvSubst subst_r ktv t2) } + +lintCoercion co@(SubCo co') + = do { (k,s,t,r) <- lintCoercion co' + ; checkRole co Nominal r + ; return (k,s,t,Representational) } + + +lintCoercion this@(AxiomRuleCo co ts cs) + = do _ks <- mapM lintType ts + eqs <- mapM lintCoercion cs + + let tyNum = length ts + + case compare (coaxrTypeArity co) tyNum of + EQ -> return () + LT -> err "Too many type arguments" + [ txt "expected" <+> int (coaxrTypeArity co) + , txt "provided" <+> int tyNum ] + GT -> err "Not enough type arguments" + [ txt "expected" <+> int (coaxrTypeArity co) + , txt "provided" <+> int tyNum ] + checkRoles 0 (coaxrAsmpRoles co) eqs + + case coaxrProves co ts [ Pair l r | (_,l,r,_) <- eqs ] of + Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] + Just (Pair l r) -> + do kL <- lintType l + kR <- lintType r + unless (eqKind kL kR) + $ err "Kind error in CoAxiomRule" + [ppr kL <+> txt "/=" <+> ppr kR] + return (kL, l, r, coaxrRole co) + where + txt = ptext . sLit + err m xs = failWithL $ + hang (txt m) 2 $ vcat (txt "Rule:" <+> ppr (coaxrName co) : xs) + + checkRoles n (e : es) ((_,_,_,r) : rs) + | e == r = checkRoles (n+1) es rs + | otherwise = err "Argument roles mismatch" + [ txt "In argument:" <+> int (n+1) + , txt "Expected:" <+> ppr e + , txt "Found:" <+> ppr r ] + checkRoles _ [] [] = return () + checkRoles n [] rs = err "Too many coercion arguments" + [ txt "Expected:" <+> int n + , txt "Provided:" <+> int (n + length rs) ] + + checkRoles n es [] = err "Not enough coercion arguments" + [ txt "Expected:" <+> int (n + length es) + , txt "Provided:" <+> int n ] + +{- +************************************************************************ +* * +\subsection[lint-monad]{The Lint monad} +* * +************************************************************************ +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] +newtype LintM a = + LintM { unLintM :: + [LintLocInfo] -> -- Locations + TvSubst -> -- Current type substitution; we also use this + -- to keep track of all the variables in scope, + -- both Ids and TyVars + WarnsAndErrs -> -- Error and warning messages so far + (Maybe a, WarnsAndErrs) } -- Result and messages (if any) + +type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) + +{- 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. +-} + +instance Functor LintM where + fmap = liftM + +instance Applicative LintM where + pure = return + (<*>) = ap + +instance Monad LintM where + return x = LintM (\ _ _ errs -> (Just x, errs)) + fail err = failWithL (text err) + m >>= k = LintM (\ loc subst errs -> + let (res, errs') = unLintM m loc subst errs in + case res of + Just r -> unLintM (k r) loc subst errs' + Nothing -> (Nothing, errs')) + +data LintLocInfo + = RhsOf Id -- The variable bound + | LambdaBodyOf Id -- The lambda-binder + | BodyOfLetRec [Id] -- One of the binders + | CaseAlt CoreAlt -- Case alternative + | CasePat CoreAlt -- The *pattern* of the case alternative + | AnExpr CoreExpr -- Some expression + | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + | TopLevelBindings + | InType Type -- Inside a type + | InCo Coercion -- Inside a coercion + +initL :: LintM a -> WarnsAndErrs -- Errors and warnings +initL m + = case unLintM m [] emptyTvSubst (emptyBag, emptyBag) of + (_, errs) -> errs + +checkL :: Bool -> MsgDoc -> LintM () +checkL True _ = return () +checkL False msg = failWithL msg + +failWithL :: MsgDoc -> LintM a +failWithL msg = LintM $ \ loc subst (warns,errs) -> + (Nothing, (warns, addMsg subst errs msg loc)) + +addErrL :: MsgDoc -> LintM () +addErrL msg = LintM $ \ loc subst (warns,errs) -> + (Just (), (warns, addMsg subst errs msg loc)) + +addWarnL :: MsgDoc -> LintM () +addWarnL msg = LintM $ \ loc subst (warns,errs) -> + (Just (), (addMsg subst warns msg loc, errs)) + +addMsg :: TvSubst -> Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc +addMsg subst msgs msg locs + = ASSERT( notNull locs ) + msgs `snocBag` mk_msg msg + where + (loc, cxt1) = dumpLoc (head locs) + cxts = [snd (dumpLoc loc) | loc <- locs] + context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$ + ptext (sLit "Substitution:") <+> ppr subst + | otherwise = cxt1 + + mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg) + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m = + LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs) + +inCasePat :: LintM Bool -- A slight hack; see the unique call site +inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs) + where + is_case_pat (CasePat {} : _) = True + is_case_pat _other = False + +addInScopeVars :: [Var] -> LintM a -> LintM a +addInScopeVars vars m + = LintM (\ loc subst errs -> unLintM m loc (extendTvInScopeList subst vars) errs) + +addInScopeVar :: Var -> LintM a -> LintM a +addInScopeVar var m + = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst var) errs) + +updateTvSubst :: TvSubst -> LintM a -> LintM a +updateTvSubst subst' m = + LintM (\ loc _ errs -> unLintM m loc subst' errs) + +getTvSubst :: LintM TvSubst +getTvSubst = LintM (\ _ subst errs -> (Just subst, errs)) + +getInScope :: LintM InScopeSet +getInScope = LintM (\ _ subst errs -> (Just (getTvInScope subst), errs)) + +applySubstTy :: InType -> LintM OutType +applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) } + +applySubstCo :: InCoercion -> LintM OutCoercion +applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) } + +extendSubstL :: TyVar -> Type -> LintM a -> LintM a +extendSubstL tv ty m + = LintM (\ loc subst errs -> unLintM m loc (Type.extendTvSubst subst tv ty) errs) + +lookupIdInScope :: Id -> LintM Id +lookupIdInScope id + | not (mustHaveLocalBinding id) + = return id -- An imported Id + | otherwise + = do { subst <- getTvSubst + ; case lookupInScope (getTvInScope subst) id of + Just v -> return v + Nothing -> do { addErrL out_of_scope + ; return id } } + where + out_of_scope = pprBndr LetBind id <+> ptext (sLit "is out of scope") + + +oneTupleDataConId :: Id -- Should not happen +oneTupleDataConId = dataConWorkId (tupleCon BoxedTuple 1) + +checkBndrIdInScope :: Var -> Var -> LintM () +checkBndrIdInScope binder id + = checkInScope msg id + where + msg = ptext (sLit "is out of scope inside info for") <+> + ppr binder + +checkTyCoVarInScope :: Var -> LintM () +checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v + +checkInScope :: SDoc -> Var -> LintM () +checkInScope loc_msg var = + do { subst <- getTvSubst + ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) + (hsep [pprBndr LetBind var, loc_msg]) } + +checkTys :: 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 alrady had the substitution applied +checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg + +checkRole :: Coercion + -> Role -- expected + -> Role -- actual + -> LintM () +checkRole co r1 r2 + = checkL (r1 == r2) + (ptext (sLit "Role incompatibility: expected") <+> ppr r1 <> comma <+> + ptext (sLit "got") <+> ppr r2 $$ + ptext (sLit "in") <+> ppr co) + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) + +dumpLoc (RhsOf v) + = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v])) + +dumpLoc (LambdaBodyOf b) + = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b)) + +dumpLoc (BodyOfLetRec []) + = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders"))) + +dumpLoc (BodyOfLetRec bs@(_:_)) + = ( getSrcLoc (head bs), brackets (ptext (sLit "in 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 (ImportedUnfolding locn) + = (locn, brackets (ptext (sLit "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 [ppr ty1, ppr ty2, ppr e]) + +mkScrutMsg :: Id -> Type -> Type -> TvSubst -> 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 [ptext (sLit "Current TV subst"), ppr subst]] + +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc +mkNonDefltMsg e + = hang (text "Case expression with DEFAULT not at the beginnning") 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 [ptext (sLit "Argument value doesn't match argument type:"), + hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), + hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), + hang (ptext (sLit "Arg:")) 4 (ppr arg)] + +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkNonFunAppMsg fun_ty arg_ty arg + = vcat [ptext (sLit "Non-function type in function position"), + hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), + hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), + hang (ptext (sLit "Arg:")) 4 (ppr arg)] + +mkLetErr :: TyVar -> CoreExpr -> MsgDoc +mkLetErr bndr rhs + = vcat [ptext (sLit "Bad `let' binding:"), + hang (ptext (sLit "Variable:")) + 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), + hang (ptext (sLit "Rhs:")) + 4 (ppr rhs)] + +mkTyAppMsg :: Type -> Type -> MsgDoc +mkTyAppMsg ty arg_ty + = vcat [text "Illegal type application:", + hang (ptext (sLit "Exp type:")) + 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), + hang (ptext (sLit "Arg type:")) + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc +mkRhsMsg binder what ty + = vcat + [hsep [ptext (sLit "The type of this binder doesn't match the type of its") <+> what <> colon, + ppr binder], + hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], + hsep [ptext (sLit "Rhs type:"), ppr ty]] + +mkLetAppMsg :: CoreExpr -> MsgDoc +mkLetAppMsg e + = hang (ptext (sLit "This argument does not satisfy the let/app invariant:")) + 2 (ppr e) + +mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc +mkRhsPrimMsg binder _rhs + = vcat [hsep [ptext (sLit "The type of this binder is primitive:"), + ppr binder], + hsep [ptext (sLit "Binder's type:"), ppr (idType binder)] + ] + +mkStrictMsg :: Id -> MsgDoc +mkStrictMsg binder + = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"), + ppr binder], + hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)] + ] + +mkNonTopExportedMsg :: Id -> MsgDoc +mkNonTopExportedMsg binder + = hsep [ptext (sLit "Non-top-level binder is marked as exported:"), ppr binder] + +mkNonTopExternalNameMsg :: Id -> MsgDoc +mkNonTopExternalNameMsg binder + = hsep [ptext (sLit "Non-top-level binder has an external name:"), ppr binder] + +mkKindErrMsg :: TyVar -> Type -> MsgDoc +mkKindErrMsg tyvar arg_ty + = vcat [ptext (sLit "Kinds don't match in type application:"), + hang (ptext (sLit "Type variable:")) + 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), + hang (ptext (sLit "Arg type:")) + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +{- Not needed now +mkArityMsg :: Id -> MsgDoc +mkArityMsg binder + = vcat [hsep [ptext (sLit "Demand type has"), + ppr (dmdTypeDepth dmd_ty), + ptext (sLit "arguments, rhs has"), + ppr (idArity binder), + ptext (sLit "arguments,"), + ppr binder], + hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty] + + ] + where (StrictSig dmd_ty) = idStrictness binder +-} +mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc +mkCastErr expr co from_ty expr_ty + = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), + ptext (sLit "From-type:") <+> ppr from_ty, + ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty, + ptext (sLit "Actual enclosed expr:") <+> ppr expr, + ptext (sLit "Coercion used in cast:") <+> ppr co + ] + +dupVars :: [[Var]] -> MsgDoc +dupVars vars + = hang (ptext (sLit "Duplicate variables brought into scope")) + 2 (ppr vars) + +dupExtVars :: [[Name]] -> MsgDoc +dupExtVars vars + = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) + 2 (ppr vars) diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs deleted file mode 100644 index 7a050a801b..0000000000 --- a/compiler/coreSyn/CoreLint.lhs +++ /dev/null @@ -1,1471 +0,0 @@ - -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% - -A ``lint'' pass to check for Core correctness - -\begin{code} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fprof-auto #-} - -module CoreLint ( lintCoreBindings, lintUnfolding, lintExpr ) where - -#include "HsVersions.h" - -import CoreSyn -import CoreFVs -import CoreUtils -import Bag -import Literal -import DataCon -import TysWiredIn -import TysPrim -import Var -import VarEnv -import VarSet -import Name -import Id -import PprCore -import ErrUtils -import Coercion -import SrcLoc -import Kind -import Type -import TypeRep -import TyCon -import CoAxiom -import BasicTypes -import StaticFlags -import ListSetOps -import PrelNames -import Outputable -import FastString -import Util -import OptCoercion ( checkAxInstCo ) -import Control.Monad -import MonadUtils -import Data.Maybe -import Pair -\end{code} - -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 ghc.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. - -%************************************************************************ -%* * -\subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface} -%* * -%************************************************************************ - -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 - -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 type lets] -~~~~~~~~~~~~~~~~~~~~~~~~ -In the desugarer, it's very very convenient to be able to say (in effect) - let a = Type Int in -That is, use a type let. See Note [Type let] in CoreSyn. - -However, when linting 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 functin - lintInTy :: Type -> LintM Type -returns a substituted type; that's the only reason it returns anything. - -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 TvSubst we are carrying down), and when we -find an occurrence of an Id, we fetch it from the in-scope set. - - -\begin{code} -lintCoreBindings :: [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 local_in_scope binds - = initL $ - addLoc TopLevelBindings $ - addInScopeVars local_in_scope $ - addInScopeVars 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 - 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) -\end{code} - -%************************************************************************ -%* * -\subsection[lintUnfolding]{lintUnfolding} -%* * -%************************************************************************ - -We use this to check all unfoldings that come in from interfaces -(it is very painful to catch errors otherwise): - -\begin{code} -lintUnfolding :: SrcLoc - -> [Var] -- Treat these as in scope - -> CoreExpr - -> Maybe MsgDoc -- Nothing => OK - -lintUnfolding locn vars expr - | isEmptyBag errs = Nothing - | otherwise = Just (pprMessageBag errs) - where - (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $ - addInScopeVars vars $ - lintCoreExpr expr) - -lintExpr :: [Var] -- Treat these as in scope - -> CoreExpr - -> Maybe MsgDoc -- Nothing => OK - -lintExpr vars expr - | isEmptyBag errs = Nothing - | otherwise = Just (pprMessageBag errs) - where - (_warns, errs) = initL (addLoc TopLevelBindings $ - addInScopeVars vars $ - lintCoreExpr expr) -\end{code} - -%************************************************************************ -%* * -\subsection[lintCoreBinding]{lintCoreBinding} -%* * -%************************************************************************ - -Check a core binding, returning the list of variables bound. - -\begin{code} -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 <- lintCoreExpr rhs - ; lintBinder binder -- Check match to RHS type - ; binder_ty <- applySubstTy binder_ty - ; checkTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) ty) - - -- Check the let/app invariant - -- See Note [CoreSyn let/app invariant] in CoreSyn - ; checkL (not (isUnLiftedType binder_ty) - || (isNonRec rec_flag && exprOkForSpeculation rhs)) - (mkRhsPrimMsg binder rhs) - - -- Check that if the binder is top-level or recursive, it's not demanded - ; checkL (not (isStrictId binder) - || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))) - (mkStrictMsg binder) - - -- Check that if the binder is local, it is not marked as exported - ; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag) - (mkNonTopExportedMsg binder) - - -- Check that if the binder is local, it does not have an external name - ; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag) - (mkNonTopExternalNameMsg binder) - - -- Check whether binder's specialisations contain any out-of-scope variables - ; mapM_ (checkBndrIdInScope binder) bndr_vars - - ; when (isStrongLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder)) - (addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder)) - -- Only non-rule loop breakers inhibit inlining - - -- Check whether arity and demand type are consistent (only if demand analysis - -- already happened) - -- - -- Note (Apr 2014): this is actually ok. See Note [Demand analysis for trivial right-hand sides] - -- in DmdAnal. After eta-expansion in CorePrep the rhs is no longer trivial. - -- ; let dmdTy = idStrictness binder - -- ; checkL (case dmdTy of - -- StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs) - -- (mkArityMsg 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. - where - binder_ty = idType binder - bndr_vars = varSetElems (idFreeVars binder) - - -- If you edit this function, you may need to update the GHC formalism - -- See Note [GHC Formalism] - lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) - | otherwise = return () - -lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () -lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) - | isStableSource src - = do { ty <- lintCoreExpr rhs - ; checkTys bndr_ty ty (mkRhsMsg bndr (ptext (sLit "unfolding")) ty) } -lintIdUnfolding _ _ _ - = return () -- We could check more -\end{code} - -%************************************************************************ -%* * -\subsection[lintCoreExpr]{lintCoreExpr} -%* * -%************************************************************************ - -\begin{code} ---type InKind = Kind -- Substitution not yet applied -type InType = Type -type InCoercion = Coercion -type InVar = Var -type InTyVar = TyVar - -type OutKind = Kind -- Substitution has been applied to this, - -- but has not been linted yet -type LintedKind = Kind -- Substitution applied, and type is linted - -type OutType = Type -- Substitution has been applied to this, - -- but has not been linted yet - -type LintedType = Type -- Substitution applied, and type is linted - -type OutCoercion = Coercion -type OutVar = Var -type OutTyVar = TyVar - -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) - = do { checkL (not (var == oneTupleDataConId)) - (ptext (sLit "Illegal one-tuple")) - - ; checkL (isId var && not (isCoVar var)) - (ptext (sLit "Non term variable") <+> ppr var) - - ; checkDeadIdOcc var - ; var' <- lookupIdInScope var - ; return (idType var') } - -lintCoreExpr (Lit lit) - = return (literalType lit) - -lintCoreExpr (Cast expr co) - = do { expr_ty <- lintCoreExpr expr - ; co' <- applySubstCo co - ; (_, from_ty, to_ty, r) <- lintCoercion co' - ; checkRole co' Representational r - ; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) - ; return to_ty } - -lintCoreExpr (Tick (Breakpoint _ ids) expr) - = do forM_ ids $ \id -> do - checkDeadIdOcc id - lookupIdInScope id - lintCoreExpr expr - -lintCoreExpr (Tick _other_tickish expr) - = lintCoreExpr expr - -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) $ checkTyKind 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]) - (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) } - - | otherwise - = failWithL (mkLetErr bndr rhs) -- Not quite accurate - -lintCoreExpr (Let (Rec pairs) body) - = lintAndScopeIds bndrs $ \_ -> - do { checkL (null dups) (dupVars dups) - ; 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 <- lintCoreExpr fun - ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args } - where - (fun, args) = collectArgs e - -lintCoreExpr (Lam var expr) - = addLoc (LambdaBodyOf var) $ - lintBinder var $ \ var' -> - do { body_ty <- lintCoreExpr expr - ; if isId var' then - return (mkFunTy (idType var') body_ty) - else - return (mkForAllTy var' body_ty) - } - -- The applySubstTy is needed to apply the subst to var - -lintCoreExpr e@(Case scrut var alt_ty alts) = - -- Check the scrutinee - do { scrut_ty <- lintCoreExpr scrut - ; alt_ty <- lintInTy alt_ty - ; var_ty <- lintInTy (idType var) - - ; case tyConAppTyCon_maybe (idType var) of - Just tycon - | debugIsOn && - isAlgTyCon tycon && - not (isFamilyTyCon tycon || isAbstractTyCon tycon) && - null (tyConDataCons tycon) -> - 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 <- getTvSubst - ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) - - ; lintAndScopeId var $ \_ -> - do { -- Check the alternatives - mapM_ (lintCoreAlt scrut_ty alt_ty) alts - ; checkCaseAlts e scrut_ty alts - ; return alt_ty } } - --- This case can't happen; linting types in expressions gets routed through --- lintCoreArgs -lintCoreExpr (Type ty) - = pprPanic "lintCoreExpr" (ppr ty) - -lintCoreExpr (Coercion co) - = do { (_kind, ty1, ty2, role) <- lintInCo co - ; return (mkCoercionType role ty1 ty2) } - -\end{code} - -Note [Kind instantiation in coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following coercion axiom: - ax_co [(k_ag :: BOX), (f_aa :: k_ag -> Constraint)] :: T k_ag f_aa ~ f_aa - -Consider the following instantiation: - ax_co <* -> *> - -We need to split the co_ax_tvs into kind and type variables in order -to find out the coercion kind instantiations. Those can only be Refl -since we don't have kind coercions. This is just a way to represent -kind instantiation. - -We use the number of kind variables to know how to split the coercions -instantiations between kind coercions and type coercions. We lint the -kind coercions and produce the following substitution which is to be -applied in the type variables: - k_ag ~~> * -> * - -%************************************************************************ -%* * -\subsection[lintCoreArgs]{lintCoreArgs} -%* * -%************************************************************************ - -The basic version of these functions checks that the argument is a -subtype of the required type, as one would expect. - -\begin{code} -lintCoreArg :: OutType -> CoreArg -> LintM OutType -lintCoreArg fun_ty (Type arg_ty) - = do { arg_ty' <- applySubstTy arg_ty - ; lintTyApp fun_ty arg_ty' } - -lintCoreArg fun_ty arg - = do { arg_ty <- lintCoreExpr arg - ; 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 [] - = checkTys 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 (tyvar,body_ty) <- splitForAllTy_maybe fun_ty - , isTyVar tyvar - = do { checkTyKind tyvar arg_ty - ; return (substTyWith [tyvar] [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 { checkTys arg arg_ty err1 - ; return res } - | otherwise - = failWithL err2 - where - err1 = mkAppMsg fun_ty arg_ty arg - err2 = mkNonFunAppMsg fun_ty arg_ty arg -\end{code} - -\begin{code} -checkTyKind :: 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] -checkTyKind tyvar arg_ty - | isSuperKind tyvar_kind -- kind forall - = lintKind arg_ty - -- Arg type might be boxed for a function with an uncommitted - -- tyvar; notably this is used so that we can give - -- error :: forall a:*. String -> a - -- and then apply it to both boxed and unboxed types. - | otherwise -- type forall - = do { arg_kind <- lintType arg_ty - ; unless (arg_kind `isSubKind` tyvar_kind) - (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "xx" <+> ppr arg_kind))) } - where - tyvar_kind = tyVarKind tyvar - -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 - (ptext (sLit "Occurrence of a dead Id") <+> ppr id) } - | otherwise - = return () -\end{code} - - -%************************************************************************ -%* * -\subsection[lintCoreAlts]{lintCoreAlts} -%* * -%************************************************************************ - -\begin{code} -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 simplifer correctly eliminates case that can't --- possibly match. - -checkCaseAlts e ty alts = - do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) - ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) - - -- 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 CoreSyn) 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 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 -\end{code} - -\begin{code} -checkAltExpr :: CoreExpr -> OutType -> LintM () -checkAltExpr expr ann_ty - = do { actual_ty <- lintCoreExpr expr - ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) } - -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 { checkL (null args) (mkDefaultArgsMsg args) - ; checkAltExpr rhs alt_ty } - -lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) - | litIsLifted lit - = failWithL integerScrutinisedMsg - | otherwise - = do { checkL (null args) (mkDefaultArgsMsg args) - ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) - ; checkAltExpr 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 - checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con) - ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys - - -- And now bring the new binders into scope - ; lintBinders args $ \ args' -> do - { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args') - ; checkAltExpr rhs alt_ty } } - - | otherwise -- Scrut-ty is wrong shape - = addErrL (mkBadAltMsg scrut_ty alt) -\end{code} - -%************************************************************************ -%* * -\subsection[lint-types]{Types} -%* * -%************************************************************************ - -\begin{code} --- 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 :: [Var] -> ([Var] -> LintM a) -> LintM a -lintBinders [] linterF = linterF [] -lintBinders (var:vars) linterF = lintBinder var $ \var' -> - lintBinders vars $ \ vars' -> - linterF (var':vars') - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintBinder :: Var -> (Var -> LintM a) -> LintM a -lintBinder var linterF - | isId var = lintIdBndr var linterF - | otherwise = lintTyBndr var linterF - -lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a -lintTyBndr tv thing_inside - = do { subst <- getTvSubst - ; let (subst', tv') = Type.substTyVarBndr subst tv - ; lintTyBndrKind tv' - ; updateTvSubst subst' (thing_inside tv') } - -lintIdBndr :: Id -> (Id -> 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 id linterF - = do { lintAndScopeId id $ \id' -> linterF id' } - -lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a -lintAndScopeIds ids linterF - = go ids - where - go [] = linterF [] - go (id:ids) = lintAndScopeId id $ \id -> - lintAndScopeIds ids $ \ids -> - linterF (id:ids) - -lintAndScopeId :: InVar -> (OutVar -> LintM a) -> LintM a -lintAndScopeId id linterF - = do { ty <- lintInTy (idType id) - ; let id' = setIdType id ty - ; addInScopeVar id' $ (linterF id') } -\end{code} - - -%************************************************************************ -%* * - Types and kinds -%* * -%************************************************************************ - -We have a single linter for types and kinds. That is convenient -because sometimes it's not clear whether the thing we are looking -at is a type or a kind. - -\begin{code} -lintInTy :: InType -> LintM LintedType --- 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' - ; return ty' } - -------------------- -lintTyBndrKind :: OutTyVar -> LintM () --- Handles both type and kind foralls. -lintTyBndrKind tv = lintKind (tyVarKind tv) - -------------------- -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 { checkTyCoVarInScope tv - ; return (tyVarKind tv) } - -- We checked its kind when we added it to the envt - -lintType ty@(AppTy t1 t2) - = do { k1 <- lintType t1 - ; k2 <- lintType t2 - ; lint_ty_app ty k1 [(t2,k2)] } - -lintType ty@(FunTy t1 t2) -- (->) has two different rules, for types and kinds - = do { k1 <- lintType t1 - ; k2 <- lintType t2 - ; lintArrow (ptext (sLit "type or kind") <+> quotes (ppr ty)) k1 k2 } - -lintType ty@(TyConApp tc tys) - | Just ty' <- coreView ty - = lintType ty' -- Expand type synonyms, so that we do not bogusly complain - -- about un-saturated type synonyms - - | isUnLiftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc - -- See Note [The kind invariant] in TypeRep - -- Also type synonyms and type families - , length tys < tyConArity tc - = failWithL (hang (ptext (sLit "Un-saturated type application")) 2 (ppr ty)) - - | otherwise - = do { ks <- mapM lintType tys - ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } - -lintType (ForAllTy tv ty) - = do { lintTyBndrKind tv - ; addInScopeVar tv (lintType ty) } - -lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) - -\end{code} - - -\begin{code} -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 (isSuperKind sk) - (addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k) - 2 (ptext (sLit "has kind:") <+> ppr sk))) } -\end{code} - - -\begin{code} -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 - | isSuperKind k1 - = return superKind - | otherwise - = do { unless (okArrowArgKind k1) (addErrL (msg (ptext (sLit "argument")) k1)) - ; unless (okArrowResultKind k2) (addErrL (msg (ptext (sLit "result")) k2)) - ; return liftedTypeKind } - where - msg ar k - = vcat [ hang (ptext (sLit "Ill-kinded") <+> ar) - 2 (ptext (sLit "in") <+> what) - , what <+> ptext (sLit "kind:") <+> ppr k ] - -lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind -lint_ty_app ty k tys - = lint_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys - ----------------- -lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind -lint_co_app ty k tys - = lint_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys - ----------------- -lintTyLit :: TyLit -> LintM () -lintTyLit (NumTyLit n) - | n >= 0 = return () - | otherwise = failWithL msg - where msg = ptext (sLit "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 - = foldlM go_app kfn kas - where - fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc - , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) - , nest 2 (ptext (sLit "Arg kinds =") <+> ppr kas) ] - - go_app kfn ka - | Just kfn' <- coreView kfn - = go_app kfn' ka - - go_app (FunTy kfa kfb) (_,ka) - = do { unless (ka `isSubKind` kfa) (addErrL fail_msg) - ; return kfb } - - go_app (ForAllTy kv kfn) (ta,ka) - = do { unless (ka `isSubKind` tyVarKind kv) (addErrL fail_msg) - ; return (substKiWith [kv] [ta] kfn) } - - go_app _ _ = failWithL fail_msg -\end{code} - -%************************************************************************ -%* * - Linting coercions -%* * -%************************************************************************ - -\begin{code} -lintInCo :: InCoercion -> LintM (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' } - -lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType, Role) --- Check the kind of a coercion term, returning the kind --- Post-condition: the returned OutTypes are lint-free --- and have the same kind as each other - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoercion (Refl r ty) - = do { k <- lintType ty - ; return (k, ty, ty, r) } - -lintCoercion co@(TyConAppCo r tc cos) - | tc `hasKey` funTyConKey - , [co1,co2] <- cos - = do { (k1,s1,t1,r1) <- lintCoercion co1 - ; (k2,s2,t2,r2) <- lintCoercion co2 - ; rk <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2 - ; checkRole co1 r r1 - ; checkRole co2 r r2 - ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2, r) } - - | Just {} <- synTyConDefn_maybe tc - = failWithL (ptext (sLit "Synonym in TyConAppCo:") <+> ppr co) - - | otherwise - = do { (ks,ss,ts,rs) <- mapAndUnzip4M lintCoercion cos - ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks) - ; _ <- zipWith3M checkRole cos (tyConRolesX r tc) rs - ; return (rk, mkTyConApp tc ss, mkTyConApp tc ts, r) } - -lintCoercion co@(AppCo co1 co2) - = do { (k1,s1,t1,r1) <- lintCoercion co1 - ; (k2,s2,t2,r2) <- lintCoercion co2 - ; rk <- lint_co_app co k1 [(s2,k2)] - ; if r1 == Phantom - then checkL (r2 == Phantom || r2 == Nominal) - (ptext (sLit "Second argument in AppCo cannot be R:") $$ - ppr co) - else checkRole co Nominal r2 - ; return (rk, mkAppTy s1 s2, mkAppTy t1 t2, r1) } - -lintCoercion (ForAllCo tv co) - = do { lintTyBndrKind tv - ; (k, s, t, r) <- addInScopeVar tv (lintCoercion co) - ; return (k, mkForAllTy tv s, mkForAllTy tv t, r) } - -lintCoercion (CoVarCo cv) - | not (isCoVar cv) - = failWithL (hang (ptext (sLit "Bad CoVarCo:") <+> ppr cv) - 2 (ptext (sLit "With offending type:") <+> ppr (varType cv))) - | otherwise - = do { checkTyCoVarInScope cv - ; cv' <- lookupIdInScope cv - ; let (s,t) = coVarKind cv' - k = typeKind s - r = coVarRole cv' - ; when (isSuperKind k) $ - do { checkL (r == Nominal) (hang (ptext (sLit "Non-nominal kind equality")) - 2 (ppr cv)) - ; checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality")) - 2 (ppr cv)) } - ; return (k, s, t, r) } - -lintCoercion (UnivCo r ty1 ty2) - = do { k1 <- lintType ty1 - ; _k2 <- lintType ty2 --- ; unless (k1 `eqKind` k2) $ --- failWithL (hang (ptext (sLit "Unsafe coercion changes kind")) --- 2 (ppr co)) - ; return (k1, ty1, ty2, r) } - -lintCoercion (SymCo co) - = do { (k, ty1, ty2, r) <- lintCoercion co - ; return (k, ty2, ty1, r) } - -lintCoercion co@(TransCo co1 co2) - = do { (k1, ty1a, ty1b, r1) <- lintCoercion co1 - ; (_, ty2a, ty2b, r2) <- lintCoercion co2 - ; checkL (ty1b `eqType` ty2a) - (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) - 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) - ; checkRole co r1 r2 - ; return (k1, ty1a, ty2b, r1) } - -lintCoercion the_co@(NthCo n co) - = do { (_,s,t,r) <- lintCoercion co - ; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of - (Just (tc_s, tys_s), Just (tc_t, tys_t)) - | tc_s == tc_t - , tys_s `equalLength` tys_t - , n < length tys_s - -> return (ks, ts, tt, tr) - where - ts = getNth tys_s n - tt = getNth tys_t n - tr = nthRole r tc_s n - ks = typeKind ts - - _ -> failWithL (hang (ptext (sLit "Bad getNth:")) - 2 (ppr the_co $$ ppr s $$ ppr t)) } - -lintCoercion the_co@(LRCo lr co) - = do { (_,s,t,r) <- lintCoercion co - ; checkRole co Nominal r - ; case (splitAppTy_maybe s, splitAppTy_maybe t) of - (Just s_pr, Just t_pr) - -> return (k, s_pick, t_pick, Nominal) - where - s_pick = pickLR lr s_pr - t_pick = pickLR lr t_pr - k = typeKind s_pick - - _ -> failWithL (hang (ptext (sLit "Bad LRCo:")) - 2 (ppr the_co $$ ppr s $$ ppr t)) } - -lintCoercion (InstCo co arg_ty) - = do { (k,s,t,r) <- lintCoercion co - ; arg_kind <- lintType arg_ty - ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of - (Just (tv1,ty1), Just (tv2,ty2)) - | arg_kind `isSubKind` tyVarKind tv1 - -> return (k, substTyWith [tv1] [arg_ty] ty1, - substTyWith [tv2] [arg_ty] ty2, r) - | otherwise - -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) - _ -> failWithL (ptext (sLit "Bad argument of inst")) } - -lintCoercion co@(AxiomInstCo con ind cos) - = do { unless (0 <= ind && ind < brListLength (coAxiomBranches con)) - (bad_ax (ptext (sLit "index out of range"))) - -- See Note [Kind instantiation in coercions] - ; let CoAxBranch { cab_tvs = ktvs - , cab_roles = roles - , cab_lhs = lhs - , cab_rhs = rhs } = coAxiomNthBranch con ind - ; unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths"))) - ; in_scope <- getInScope - ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv - ; (subst_l, subst_r) <- foldlM check_ki - (empty_subst, empty_subst) - (zip3 ktvs roles cos) - ; let lhs' = Type.substTys subst_l lhs - rhs' = Type.substTy subst_r rhs - ; case checkAxInstCo co of - Just bad_branch -> bad_ax $ ptext (sLit "inconsistent with") <+> (pprCoAxBranch (coAxiomTyCon con) bad_branch) - Nothing -> return () - ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs', coAxiomRole con) } - where - bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what) - 2 (ppr co)) - - check_ki (subst_l, subst_r) (ktv, role, co) - = do { (k, t1, t2, r) <- lintCoercion co - ; checkRole co role r - ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv) - -- Using subst_l is ok, because subst_l and subst_r - -- must agree on kind equalities - ; unless (k `isSubKind` ktv_kind) - (bad_ax (ptext (sLit "check_ki2") <+> vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] )) - ; return (Type.extendTvSubst subst_l ktv t1, - Type.extendTvSubst subst_r ktv t2) } - -lintCoercion co@(SubCo co') - = do { (k,s,t,r) <- lintCoercion co' - ; checkRole co Nominal r - ; return (k,s,t,Representational) } - - -lintCoercion this@(AxiomRuleCo co ts cs) - = do _ks <- mapM lintType ts - eqs <- mapM lintCoercion cs - - let tyNum = length ts - - case compare (coaxrTypeArity co) tyNum of - EQ -> return () - LT -> err "Too many type arguments" - [ txt "expected" <+> int (coaxrTypeArity co) - , txt "provided" <+> int tyNum ] - GT -> err "Not enough type arguments" - [ txt "expected" <+> int (coaxrTypeArity co) - , txt "provided" <+> int tyNum ] - checkRoles 0 (coaxrAsmpRoles co) eqs - - case coaxrProves co ts [ Pair l r | (_,l,r,_) <- eqs ] of - Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] - Just (Pair l r) -> - do kL <- lintType l - kR <- lintType r - unless (eqKind kL kR) - $ err "Kind error in CoAxiomRule" - [ppr kL <+> txt "/=" <+> ppr kR] - return (kL, l, r, coaxrRole co) - where - txt = ptext . sLit - err m xs = failWithL $ - hang (txt m) 2 $ vcat (txt "Rule:" <+> ppr (coaxrName co) : xs) - - checkRoles n (e : es) ((_,_,_,r) : rs) - | e == r = checkRoles (n+1) es rs - | otherwise = err "Argument roles mismatch" - [ txt "In argument:" <+> int (n+1) - , txt "Expected:" <+> ppr e - , txt "Found:" <+> ppr r ] - checkRoles _ [] [] = return () - checkRoles n [] rs = err "Too many coercion arguments" - [ txt "Expected:" <+> int n - , txt "Provided:" <+> int (n + length rs) ] - - checkRoles n es [] = err "Not enough coercion arguments" - [ txt "Expected:" <+> int (n + length es) - , txt "Provided:" <+> int n ] - -\end{code} - -%************************************************************************ -%* * -\subsection[lint-monad]{The Lint monad} -%* * -%************************************************************************ - -\begin{code} - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] -newtype LintM a = - LintM { unLintM :: - [LintLocInfo] -> -- Locations - TvSubst -> -- Current type substitution; we also use this - -- to keep track of all the variables in scope, - -- both Ids and TyVars - WarnsAndErrs -> -- Error and warning messages so far - (Maybe a, WarnsAndErrs) } -- Result and messages (if any) - -type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) - -{- 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. --} - -instance Functor LintM where - fmap = liftM - -instance Applicative LintM where - pure = return - (<*>) = ap - -instance Monad LintM where - return x = LintM (\ _ _ errs -> (Just x, errs)) - fail err = failWithL (text err) - m >>= k = LintM (\ loc subst errs -> - let (res, errs') = unLintM m loc subst errs in - case res of - Just r -> unLintM (k r) loc subst errs' - Nothing -> (Nothing, errs')) - -data LintLocInfo - = RhsOf Id -- The variable bound - | LambdaBodyOf Id -- The lambda-binder - | BodyOfLetRec [Id] -- One of the binders - | CaseAlt CoreAlt -- Case alternative - | CasePat CoreAlt -- The *pattern* of the case alternative - | AnExpr CoreExpr -- Some expression - | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) - | TopLevelBindings - | InType Type -- Inside a type - | InCo Coercion -- Inside a coercion -\end{code} - - -\begin{code} -initL :: LintM a -> WarnsAndErrs -- Errors and warnings -initL m - = case unLintM m [] emptyTvSubst (emptyBag, emptyBag) of - (_, errs) -> errs -\end{code} - -\begin{code} -checkL :: Bool -> MsgDoc -> LintM () -checkL True _ = return () -checkL False msg = failWithL msg - -failWithL :: MsgDoc -> LintM a -failWithL msg = LintM $ \ loc subst (warns,errs) -> - (Nothing, (warns, addMsg subst errs msg loc)) - -addErrL :: MsgDoc -> LintM () -addErrL msg = LintM $ \ loc subst (warns,errs) -> - (Just (), (warns, addMsg subst errs msg loc)) - -addWarnL :: MsgDoc -> LintM () -addWarnL msg = LintM $ \ loc subst (warns,errs) -> - (Just (), (addMsg subst warns msg loc, errs)) - -addMsg :: TvSubst -> Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc -addMsg subst msgs msg locs - = ASSERT( notNull locs ) - msgs `snocBag` mk_msg msg - where - (loc, cxt1) = dumpLoc (head locs) - cxts = [snd (dumpLoc loc) | loc <- locs] - context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$ - ptext (sLit "Substitution:") <+> ppr subst - | otherwise = cxt1 - - mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg) - -addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m = - LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs) - -inCasePat :: LintM Bool -- A slight hack; see the unique call site -inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs) - where - is_case_pat (CasePat {} : _) = True - is_case_pat _other = False - -addInScopeVars :: [Var] -> LintM a -> LintM a -addInScopeVars vars m - = LintM (\ loc subst errs -> unLintM m loc (extendTvInScopeList subst vars) errs) - -addInScopeVar :: Var -> LintM a -> LintM a -addInScopeVar var m - = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst var) errs) - -updateTvSubst :: TvSubst -> LintM a -> LintM a -updateTvSubst subst' m = - LintM (\ loc _ errs -> unLintM m loc subst' errs) - -getTvSubst :: LintM TvSubst -getTvSubst = LintM (\ _ subst errs -> (Just subst, errs)) - -getInScope :: LintM InScopeSet -getInScope = LintM (\ _ subst errs -> (Just (getTvInScope subst), errs)) - -applySubstTy :: InType -> LintM OutType -applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) } - -applySubstCo :: InCoercion -> LintM OutCoercion -applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) } - -extendSubstL :: TyVar -> Type -> LintM a -> LintM a -extendSubstL tv ty m - = LintM (\ loc subst errs -> unLintM m loc (Type.extendTvSubst subst tv ty) errs) -\end{code} - -\begin{code} -lookupIdInScope :: Id -> LintM Id -lookupIdInScope id - | not (mustHaveLocalBinding id) - = return id -- An imported Id - | otherwise - = do { subst <- getTvSubst - ; case lookupInScope (getTvInScope subst) id of - Just v -> return v - Nothing -> do { addErrL out_of_scope - ; return id } } - where - out_of_scope = pprBndr LetBind id <+> ptext (sLit "is out of scope") - - -oneTupleDataConId :: Id -- Should not happen -oneTupleDataConId = dataConWorkId (tupleCon BoxedTuple 1) - -checkBndrIdInScope :: Var -> Var -> LintM () -checkBndrIdInScope binder id - = checkInScope msg id - where - msg = ptext (sLit "is out of scope inside info for") <+> - ppr binder - -checkTyCoVarInScope :: Var -> LintM () -checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v - -checkInScope :: SDoc -> Var -> LintM () -checkInScope loc_msg var = - do { subst <- getTvSubst - ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) - (hsep [pprBndr LetBind var, loc_msg]) } - -checkTys :: 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 alrady had the substitution applied -checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg - -checkRole :: Coercion - -> Role -- expected - -> Role -- actual - -> LintM () -checkRole co r1 r2 - = checkL (r1 == r2) - (ptext (sLit "Role incompatibility: expected") <+> ppr r1 <> comma <+> - ptext (sLit "got") <+> ppr r2 $$ - ptext (sLit "in") <+> ppr co) - -\end{code} - -%************************************************************************ -%* * -\subsection{Error messages} -%* * -%************************************************************************ - -\begin{code} -dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) - -dumpLoc (RhsOf v) - = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v])) - -dumpLoc (LambdaBodyOf b) - = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b)) - -dumpLoc (BodyOfLetRec []) - = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders"))) - -dumpLoc (BodyOfLetRec bs@(_:_)) - = ( getSrcLoc (head bs), brackets (ptext (sLit "in 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 (ImportedUnfolding locn) - = (locn, brackets (ptext (sLit "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)] -\end{code} - -\begin{code} ------------------------------------------------------- --- 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 [ppr ty1, ppr ty2, ppr e]) - -mkScrutMsg :: Id -> Type -> Type -> TvSubst -> 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 [ptext (sLit "Current TV subst"), ppr subst]] - -mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc -mkNonDefltMsg e - = hang (text "Case expression with DEFAULT not at the beginnning") 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 [ptext (sLit "Argument value doesn't match argument type:"), - hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), - hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), - hang (ptext (sLit "Arg:")) 4 (ppr arg)] - -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc -mkNonFunAppMsg fun_ty arg_ty arg - = vcat [ptext (sLit "Non-function type in function position"), - hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), - hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), - hang (ptext (sLit "Arg:")) 4 (ppr arg)] - -mkLetErr :: TyVar -> CoreExpr -> MsgDoc -mkLetErr bndr rhs - = vcat [ptext (sLit "Bad `let' binding:"), - hang (ptext (sLit "Variable:")) - 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), - hang (ptext (sLit "Rhs:")) - 4 (ppr rhs)] - -mkTyAppMsg :: Type -> Type -> MsgDoc -mkTyAppMsg ty arg_ty - = vcat [text "Illegal type application:", - hang (ptext (sLit "Exp type:")) - 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), - hang (ptext (sLit "Arg type:")) - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc -mkRhsMsg binder what ty - = vcat - [hsep [ptext (sLit "The type of this binder doesn't match the type of its") <+> what <> colon, - ppr binder], - hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], - hsep [ptext (sLit "Rhs type:"), ppr ty]] - -mkLetAppMsg :: CoreExpr -> MsgDoc -mkLetAppMsg e - = hang (ptext (sLit "This argument does not satisfy the let/app invariant:")) - 2 (ppr e) - -mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc -mkRhsPrimMsg binder _rhs - = vcat [hsep [ptext (sLit "The type of this binder is primitive:"), - ppr binder], - hsep [ptext (sLit "Binder's type:"), ppr (idType binder)] - ] - -mkStrictMsg :: Id -> MsgDoc -mkStrictMsg binder - = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"), - ppr binder], - hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)] - ] - -mkNonTopExportedMsg :: Id -> MsgDoc -mkNonTopExportedMsg binder - = hsep [ptext (sLit "Non-top-level binder is marked as exported:"), ppr binder] - -mkNonTopExternalNameMsg :: Id -> MsgDoc -mkNonTopExternalNameMsg binder - = hsep [ptext (sLit "Non-top-level binder has an external name:"), ppr binder] - -mkKindErrMsg :: TyVar -> Type -> MsgDoc -mkKindErrMsg tyvar arg_ty - = vcat [ptext (sLit "Kinds don't match in type application:"), - hang (ptext (sLit "Type variable:")) - 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (ptext (sLit "Arg type:")) - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -{- Not needed now -mkArityMsg :: Id -> MsgDoc -mkArityMsg binder - = vcat [hsep [ptext (sLit "Demand type has"), - ppr (dmdTypeDepth dmd_ty), - ptext (sLit "arguments, rhs has"), - ppr (idArity binder), - ptext (sLit "arguments,"), - ppr binder], - hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty] - - ] - where (StrictSig dmd_ty) = idStrictness binder --} -mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc -mkCastErr expr co from_ty expr_ty - = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), - ptext (sLit "From-type:") <+> ppr from_ty, - ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty, - ptext (sLit "Actual enclosed expr:") <+> ppr expr, - ptext (sLit "Coercion used in cast:") <+> ppr co - ] - -dupVars :: [[Var]] -> MsgDoc -dupVars vars - = hang (ptext (sLit "Duplicate variables brought into scope")) - 2 (ppr vars) - -dupExtVars :: [[Name]] -> MsgDoc -dupExtVars vars - = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) - 2 (ppr vars) -\end{code} diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs new file mode 100644 index 0000000000..9037fcb126 --- /dev/null +++ b/compiler/coreSyn/CorePrep.hs @@ -0,0 +1,1208 @@ +{- +(c) The University of Glasgow, 1994-2006 + + +Core pass to saturate constructors and PrimOps +-} + +{-# LANGUAGE BangPatterns, CPP #-} + +module CorePrep ( + corePrepPgm, corePrepExpr, cvtLitInteger, + lookupMkIntegerName, lookupIntegerSDataConName + ) where + +#include "HsVersions.h" + +import OccurAnal + +import HscTypes +import PrelNames +import CoreUtils +import CoreArity +import CoreFVs +import CoreMonad ( endPassIO, CoreToDo(..) ) +import CoreSyn +import CoreSubst +import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here +import Type +import Literal +import Coercion +import TcEnv +import TcRnMonad +import TyCon +import Demand +import Var +import VarSet +import VarEnv +import Id +import IdInfo +import TysWiredIn +import DataCon +import PrimOp +import BasicTypes +import Module +import UniqSupply +import Maybes +import OrdList +import ErrUtils +import DynFlags +import Util +import Pair +import Outputable +import Platform +import FastString +import Config +import Data.Bits +import Data.List ( mapAccumL ) +import Control.Monad + +{- +-- --------------------------------------------------------------------------- +-- Overview +-- --------------------------------------------------------------------------- + +The goal of this pass is to prepare for code generation. + +1. Saturate constructor and primop applications. + +2. Convert to A-normal form; that is, function arguments + are always variables. + + * Use case for strict arguments: + f E ==> case E of x -> f x + (where f is strict) + + * Use let for non-trivial lazy arguments + f E ==> let x = E in f x + (were f is lazy and x is non-trivial) + +3. Similarly, convert any unboxed lets into cases. + [I'm experimenting with leaving 'ok-for-speculation' + rhss in let-form right up to this point.] + +4. Ensure that *value* lambdas only occur as the RHS of a binding + (The code generator can't deal with anything else.) + Type lambdas are ok, however, because the code gen discards them. + +5. [Not any more; nuked Jun 2002] Do the seq/par munging. + +6. Clone all local Ids. + This means that all such Ids are unique, rather than the + weaker guarantee of no clashes which the simplifier provides. + And that is what the code generator needs. + + We don't clone TyVars or CoVars. The code gen doesn't need that, + and doing so would be tiresome because then we'd need + to substitute in types and coercions. + +7. Give each dynamic CCall occurrence a fresh unique; this is + rather like the cloning step above. + +8. Inject bindings for the "implicit" Ids: + * Constructor wrappers + * Constructor workers + We want curried definitions for all of these in case they + aren't inlined by some caller. + +9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs + +10. Convert (LitInteger i t) into the core representation + for the Integer i. Normally this uses mkInteger, but if + we are using the integer-gmp implementation then there is a + special case where we use the S# constructor for Integers that + are in the range of Int. + +This is all done modulo type applications and abstractions, so that +when type erasure is done for conversion to STG, we don't end up with +any trivial or useless bindings. + + +Invariants +~~~~~~~~~~ +Here is the syntax of the Core produced by CorePrep: + + Trivial expressions + triv ::= lit | var + | triv ty | /\a. triv + | truv co | /\c. triv | triv |> co + + Applications + app ::= lit | var | app triv | app ty | app co | app |> co + + Expressions + body ::= app + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body | /\c. body + | body |> co + + Right hand sides (only place where value lambdas can occur) + rhs ::= /\a.rhs | \x.rhs | body + +We define a synonym for each of these non-terminals. Functions +with the corresponding name produce a result in that syntax. +-} + +type CpeTriv = CoreExpr -- Non-terminal 'triv' +type CpeApp = CoreExpr -- Non-terminal 'app' +type CpeBody = CoreExpr -- Non-terminal 'body' +type CpeRhs = CoreExpr -- Non-terminal 'rhs' + +{- +************************************************************************ +* * + Top level stuff +* * +************************************************************************ +-} + +corePrepPgm :: DynFlags -> HscEnv -> CoreProgram -> [TyCon] -> IO CoreProgram +corePrepPgm dflags hsc_env binds data_tycons = do + showPass dflags "CorePrep" + us <- mkSplitUniqSupply 's' + initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env + + let implicit_binds = mkDataConWorkers data_tycons + -- NB: we must feed mkImplicitBinds through corePrep too + -- so that they are suitably cloned and eta-expanded + + binds_out = initUs_ us $ do + floats1 <- corePrepTopBinds initialCorePrepEnv binds + floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds + return (deFloatTop (floats1 `appendFloats` floats2)) + + endPassIO hsc_env alwaysQualify CorePrep binds_out [] + return binds_out + +corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr +corePrepExpr dflags hsc_env expr = do + showPass dflags "CorePrep" + us <- mkSplitUniqSupply 's' + initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env + let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) + dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) + return new_expr + +corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats +-- Note [Floating out of top level bindings] +corePrepTopBinds initialCorePrepEnv binds + = go initialCorePrepEnv binds + where + go _ [] = return emptyFloats + go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind + binds' <- go env' binds + return (bind' `appendFloats` binds') + +mkDataConWorkers :: [TyCon] -> [CoreBind] +-- See Note [Data constructor workers] +-- c.f. Note [Injecting implicit bindings] in TidyPgm +mkDataConWorkers data_tycons + = [ NonRec id (Var id) -- The ice is thin here, but it works + | tycon <- data_tycons, -- CorePrep will eta-expand it + data_con <- tyConDataCons tycon, + let id = dataConWorkId data_con ] + +{- +Note [Floating out of top level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: we do need to float out of top-level bindings +Consider x = length [True,False] +We want to get + s1 = False : [] + s2 = True : s1 + x = length s2 + +We return a *list* of bindings, because we may start with + x* = f (g y) +where x is demanded, in which case we want to finish with + a = g y + x* = f a +And then x will actually end up case-bound + +Note [CafInfo and floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What happens when we try to float bindings to the top level? At this +point all the CafInfo is supposed to be correct, and we must make certain +that is true of the new top-level bindings. There are two cases +to consider + +a) The top-level binding is marked asCafRefs. In that case we are + basically fine. The floated bindings had better all be lazy lets, + so they can float to top level, but they'll all have HasCafRefs + (the default) which is safe. + +b) The top-level binding is marked NoCafRefs. This really happens + Example. CoreTidy produces + $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah... + Now CorePrep has to eta-expand to + $fApplicativeSTM = let sat = \xy. retry x y + in D:Alternative sat ...blah... + So what we *want* is + sat [NoCafRefs] = \xy. retry x y + $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah... + + So, gruesomely, we must set the NoCafRefs flag on the sat bindings, + *and* substutite the modified 'sat' into the old RHS. + + It should be the case that 'sat' is itself [NoCafRefs] (a value, no + cafs) else the original top-level binding would not itself have been + marked [NoCafRefs]. The DEBUG check in CoreToStg for + consistentCafInfo will find this. + +This is all very gruesome and horrible. It would be better to figure +out CafInfo later, after CorePrep. We'll do that in due course. +Meanwhile this horrible hack works. + + +Note [Data constructor workers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Create any necessary "implicit" bindings for data con workers. We +create the rather strange (non-recursive!) binding + + $wC = \x y -> $wC x y + +i.e. a curried constructor that allocates. This means that we can +treat the worker for a constructor like any other function in the rest +of the compiler. The point here is that CoreToStg will generate a +StgConApp for the RHS, rather than a call to the worker (which would +give a loop). As Lennart says: the ice is thin here, but it works. + +Hmm. Should we create bindings for dictionary constructors? They are +always fully applied, and the bindings are just there to support +partial applications. But it's easier to let them through. + + +Note [Dead code in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Imagine that we got an input program like this (see Trac #4962): + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g True (Just x) + g () (Just x), g) + where + g :: Show a => a -> Maybe Int -> Int + g _ Nothing = x + g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown + +After specialisation and SpecConstr, we would get something like this: + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) + where + {-# RULES g $dBool = g$Bool + g $dUnit = g$Unit #-} + g = ... + {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} + g$Bool = ... + {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} + g$Unit = ... + g$Bool_True_Just = ... + g$Unit_Unit_Just = ... + +Note that the g$Bool and g$Unit functions are actually dead code: they +are only kept alive by the occurrence analyser because they are +referred to by the rules of g, which is being kept alive by the fact +that it is used (unspecialised) in the returned pair. + +However, at the CorePrep stage there is no way that the rules for g +will ever fire, and it really seems like a shame to produce an output +program that goes to the trouble of allocating a closure for the +unreachable g$Bool and g$Unit functions. + +The way we fix this is to: + * In cloneBndr, drop all unfoldings/rules + + * In deFloatTop, run a simple dead code analyser on each top-level + RHS to drop the dead local bindings. For that call to OccAnal, we + disable the binder swap, else the occurrence analyser sometimes + introduces new let bindings for cased binders, which lead to the bug + in #5433. + +The reason we don't just OccAnal the whole output of CorePrep is that +the tidier ensures that all top-level binders are GlobalIds, so they +don't show up in the free variables any longer. So if you run the +occurrence analyser on the output of CoreTidy (or later) you e.g. turn +this program: + + Rec { + f = ... f ... + } + +Into this one: + + f = ... f ... + +(Since f is not considered to be free in its own RHS.) + + +************************************************************************ +* * + The main code +* * +************************************************************************ +-} + +cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind + -> UniqSM (CorePrepEnv, Floats) +cpeBind top_lvl env (NonRec bndr rhs) + = do { (_, bndr1) <- cpCloneBndr env bndr + ; let dmd = idDemandInfo bndr + is_unlifted = isUnLiftedType (idType bndr) + ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive + dmd + is_unlifted + env bndr1 rhs + ; let new_float = mkFloat dmd is_unlifted bndr2 rhs2 + + -- We want bndr'' in the envt, because it records + -- the evaluated-ness of the binder + ; return (extendCorePrepEnv env bndr bndr2, + addFloat floats new_float) } + +cpeBind top_lvl env (Rec pairs) + = do { let (bndrs,rhss) = unzip pairs + ; (env', bndrs1) <- cpCloneBndrs env (map fst pairs) + ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss + + ; let (floats_s, bndrs2, rhss2) = unzip3 stuff + all_pairs = foldrOL add_float (bndrs2 `zip` rhss2) + (concatFloats floats_s) + ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), + unitFloat (FloatLet (Rec all_pairs))) } + where + -- Flatten all the floats, and the currrent + -- group into a single giant Rec + add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 + add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 + add_float b _ = pprPanic "cpeBind" (ppr b) + +--------------- +cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool + -> CorePrepEnv -> Id -> CoreExpr + -> UniqSM (Floats, Id, CpeRhs) +-- Used for all bindings +cpePair top_lvl is_rec dmd is_unlifted env bndr rhs + = do { (floats1, rhs1) <- cpeRhsE env rhs + + -- See if we are allowed to float this stuff out of the RHS + ; (floats2, rhs2) <- float_from_rhs floats1 rhs1 + + -- Make the arity match up + ; (floats3, rhs') + <- if manifestArity rhs1 <= arity + then return (floats2, cpeEtaExpand arity rhs2) + else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) + -- Note [Silly extra arguments] + (do { v <- newVar (idType bndr) + ; let float = mkFloat topDmd False v rhs2 + ; return ( addFloat floats2 float + , cpeEtaExpand arity (Var v)) }) + + -- Record if the binder is evaluated + -- and otherwise trim off the unfolding altogether + -- It's not used by the code generator; getting rid of it reduces + -- heap usage and, since we may be changing uniques, we'd have + -- to substitute to keep it right + ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding + | otherwise = bndr `setIdUnfolding` noUnfolding + + ; return (floats3, bndr', rhs') } + where + is_strict_or_unlifted = (isStrictDmd dmd) || is_unlifted + + platform = targetPlatform (cpe_dynFlags env) + + arity = idArity bndr -- We must match this arity + + --------------------- + float_from_rhs floats rhs + | isEmptyFloats floats = return (emptyFloats, rhs) + | isTopLevel top_lvl = float_top floats rhs + | otherwise = float_nested floats rhs + + --------------------- + float_nested floats rhs + | wantFloatNested is_rec is_strict_or_unlifted floats rhs + = return (floats, rhs) + | otherwise = dont_float floats rhs + + --------------------- + float_top floats rhs -- Urhgh! See Note [CafInfo and floating] + | mayHaveCafRefs (idCafInfo bndr) + , allLazyTop floats + = return (floats, rhs) + + -- So the top-level binding is marked NoCafRefs + | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs + = return (floats', rhs') + + | otherwise + = dont_float floats rhs + + --------------------- + dont_float floats rhs + -- Non-empty floats, but do not want to float from rhs + -- So wrap the rhs in the floats + -- But: rhs1 might have lambdas, and we can't + -- put them inside a wrapBinds + = do { body <- rhsToBodyNF rhs + ; return (emptyFloats, wrapBinds floats body) } + +{- Note [Silly extra arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we had this + f{arity=1} = \x\y. e +We *must* match the arity on the Id, so we have to generate + f' = \x\y. e + f = \x. f' x + +It's a bizarre case: why is the arity on the Id wrong? Reason +(in the days of __inline_me__): + f{arity=0} = __inline_me__ (let v = expensive in \xy. e) +When InlineMe notes go away this won't happen any more. But +it seems good for CorePrep to be robust. +-} + +-- --------------------------------------------------------------------------- +-- CpeRhs: produces a result satisfying CpeRhs +-- --------------------------------------------------------------------------- + +cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +-- If +-- e ===> (bs, e') +-- then +-- e = let bs in e' (semantically, that is!) +-- +-- For example +-- f (g x) ===> ([v = g x], f v) + +cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) +cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) +cpeRhsE env (Lit (LitInteger i _)) + = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env) + (cpe_integerSDataCon env) i) +cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) +cpeRhsE env expr@(Var {}) = cpeApp env expr + +cpeRhsE env (Var f `App` _ `App` arg) + | f `hasKey` lazyIdKey -- Replace (lazy a) by a + = cpeRhsE env arg -- See Note [lazyId magic] in MkId + +cpeRhsE env expr@(App {}) = cpeApp env expr + +cpeRhsE env (Let bind expr) + = do { (env', new_binds) <- cpeBind NotTopLevel env bind + ; (floats, body) <- cpeRhsE env' expr + ; return (new_binds `appendFloats` floats, body) } + +cpeRhsE env (Tick tickish expr) + | ignoreTickish tickish + = cpeRhsE env expr + | otherwise -- Just SCCs actually + = do { body <- cpeBodyNF env expr + ; return (emptyFloats, Tick tickish' body) } + where + tickish' | Breakpoint n fvs <- tickish + = Breakpoint n (map (lookupCorePrepEnv env) fvs) + | otherwise + = tickish + +cpeRhsE env (Cast expr co) + = do { (floats, expr') <- cpeRhsE env expr + ; return (floats, Cast expr' co) } + +cpeRhsE env expr@(Lam {}) + = do { let (bndrs,body) = collectBinders expr + ; (env', bndrs') <- cpCloneBndrs env bndrs + ; body' <- cpeBodyNF env' body + ; return (emptyFloats, mkLams bndrs' body') } + +cpeRhsE env (Case scrut bndr ty alts) + = do { (floats, scrut') <- cpeBody env scrut + ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding + -- Record that the case binder is evaluated in the alternatives + ; (env', bndr2) <- cpCloneBndr env bndr1 + ; alts' <- mapM (sat_alt env') alts + ; return (floats, Case scrut' bndr2 ty alts') } + where + sat_alt env (con, bs, rhs) + = do { (env2, bs') <- cpCloneBndrs env bs + ; rhs' <- cpeBodyNF env2 rhs + ; return (con, bs', rhs') } + +cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr +-- Here we convert a literal Integer to the low-level +-- represenation. Exactly how we do this depends on the +-- library that implements Integer. If it's GMP we +-- use the S# data constructor for small literals. +-- See Note [Integer literals] in Literal +cvtLitInteger dflags _ (Just sdatacon) i + | inIntRange dflags i -- Special case for small integers + = mkConApp sdatacon [Lit (mkMachInt dflags i)] + +cvtLitInteger dflags mk_integer _ i + = mkApps (Var mk_integer) [isNonNegative, ints] + where isNonNegative = if i < 0 then mkConApp falseDataCon [] + else mkConApp trueDataCon [] + ints = mkListExpr intTy (f (abs i)) + f 0 = [] + f x = let low = x .&. mask + high = x `shiftR` bits + in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high + bits = 31 + mask = 2 ^ bits - 1 + +-- --------------------------------------------------------------------------- +-- CpeBody: produces a result satisfying CpeBody +-- --------------------------------------------------------------------------- + +cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody +cpeBodyNF env expr + = do { (floats, body) <- cpeBody env expr + ; return (wrapBinds floats body) } + +-------- +cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) +cpeBody env expr + = do { (floats1, rhs) <- cpeRhsE env expr + ; (floats2, body) <- rhsToBody rhs + ; return (floats1 `appendFloats` floats2, body) } + +-------- +rhsToBodyNF :: CpeRhs -> UniqSM CpeBody +rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs + ; return (wrapBinds floats body) } + +-------- +rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) +-- Remove top level lambdas by let-binding + +rhsToBody (Tick t expr) + | not (tickishScoped t) -- we can only float out of non-scoped annotations + = do { (floats, expr') <- rhsToBody expr + ; return (floats, Tick t expr') } + +rhsToBody (Cast e co) + -- You can get things like + -- case e of { p -> coerce t (\s -> ...) } + = do { (floats, e') <- rhsToBody e + ; return (floats, Cast e' co) } + +rhsToBody expr@(Lam {}) + | Just no_lam_result <- tryEtaReducePrep bndrs body + = return (emptyFloats, no_lam_result) + | all isTyVar bndrs -- Type lambdas are ok + = return (emptyFloats, expr) + | otherwise -- Some value lambdas + = do { fn <- newVar (exprType expr) + ; let rhs = cpeEtaExpand (exprArity expr) expr + float = FloatLet (NonRec fn rhs) + ; return (unitFloat float, Var fn) } + where + (bndrs,body) = collectBinders expr + +rhsToBody expr = return (emptyFloats, expr) + + + +-- --------------------------------------------------------------------------- +-- CpeApp: produces a result satisfying CpeApp +-- --------------------------------------------------------------------------- + +cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +-- May return a CpeRhs because of saturating primops +cpeApp env expr + = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0 + ; MASSERT(null ss) -- make sure we used all the strictness info + + -- Now deal with the function + ; case head of + Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth + ; return (floats, sat_app) } + _other -> return (floats, app) } + + where + -- Deconstruct and rebuild the application, floating any non-atomic + -- arguments to the outside. We collect the type of the expression, + -- the head of the application, and the number of actual value arguments, + -- all of which are used to possibly saturate this application if it + -- has a constructor or primop at the head. + + collect_args + :: CoreExpr + -> Int -- Current app depth + -> UniqSM (CpeApp, -- The rebuilt expression + (CoreExpr,Int), -- The head of the application, + -- and no. of args it was applied to + Type, -- Type of the whole expr + Floats, -- Any floats we pulled out + [Demand]) -- Remaining argument demands + + collect_args (App fun arg@(Type arg_ty)) depth + = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth + ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) } + + collect_args (App fun arg@(Coercion arg_co)) depth + = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth + ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) } + + collect_args (App fun arg) depth + = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1) + ; let + (ss1, ss_rest) = case ss of + (ss1:ss_rest) -> (ss1, ss_rest) + [] -> (topDmd, []) + (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $ + splitFunTy_maybe fun_ty + + ; (fs, arg') <- cpeArg env ss1 arg arg_ty + ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) } + + collect_args (Var v) depth + = do { v1 <- fiddleCCall v + ; let v2 = lookupCorePrepEnv env v1 + ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) } + where + stricts = case idStrictness v of + StrictSig (DmdType _ demands _) + | listLengthCmp demands depth /= GT -> demands + -- length demands <= depth + | otherwise -> [] + -- If depth < length demands, then we have too few args to + -- satisfy strictness info so we have to ignore all the + -- strictness info, e.g. + (error "urk") + -- Here, we can't evaluate the arg strictly, because this + -- partial application might be seq'd + + collect_args (Cast fun co) depth + = do { let Pair _ty1 ty2 = coercionKind co + ; (fun', hd, _, floats, ss) <- collect_args fun depth + ; return (Cast fun' co, hd, ty2, floats, ss) } + + collect_args (Tick tickish fun) depth + | ignoreTickish tickish -- Drop these notes altogether + = collect_args fun depth -- They aren't used by the code generator + + -- N-variable fun, better let-bind it + collect_args fun depth + = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty + -- The evalDmd says that it's sure to be evaluated, + -- so we'll end up case-binding it + ; return (fun', (fun', depth), ty, fun_floats, []) } + where + ty = exprType fun + +-- --------------------------------------------------------------------------- +-- CpeArg: produces a result satisfying CpeArg +-- --------------------------------------------------------------------------- + +-- This is where we arrange that a non-trivial argument is let-bound +cpeArg :: CorePrepEnv -> Demand + -> CoreArg -> Type -> UniqSM (Floats, CpeTriv) +cpeArg env dmd arg arg_ty + = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda + ; (floats2, arg2) <- if want_float floats1 arg1 + then return (floats1, arg1) + else do { body1 <- rhsToBodyNF arg1 + ; return (emptyFloats, wrapBinds floats1 body1) } + -- Else case: arg1 might have lambdas, and we can't + -- put them inside a wrapBinds + + ; if cpe_ExprIsTrivial arg2 -- Do not eta expand a trivial argument + then return (floats2, arg2) + else do + { v <- newVar arg_ty + ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 + arg_float = mkFloat dmd is_unlifted v arg3 + ; return (addFloat floats2 arg_float, varToCoreExpr v) } } + where + is_unlifted = isUnLiftedType arg_ty + is_strict = isStrictDmd dmd + want_float = wantFloatNested NonRecursive (is_strict || is_unlifted) + +{- +Note [Floating unlifted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider C (let v* = expensive in v) + +where the "*" indicates "will be demanded". Usually v will have been +inlined by now, but let's suppose it hasn't (see Trac #2756). Then we +do *not* want to get + + let v* = expensive in C v + +because that has different strictness. Hence the use of 'allLazy'. +(NB: the let v* turns into a FloatCase, in mkLocalNonRec.) + + +------------------------------------------------------------------------------ +-- Building the saturated syntax +-- --------------------------------------------------------------------------- + +maybeSaturate deals with saturating primops and constructors +The type is the type of the entire application +-} + +maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs +maybeSaturate fn expr n_args + | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg + -- A gruesome special case + = saturateDataToTag sat_expr + + | hasNoBinding fn -- There's no binding + = return sat_expr + + | otherwise + = return expr + where + fn_arity = idArity fn + excess_arity = fn_arity - n_args + sat_expr = cpeEtaExpand excess_arity expr + +------------- +saturateDataToTag :: CpeApp -> UniqSM CpeApp +-- See Note [dataToTag magic] +saturateDataToTag sat_expr + = do { let (eta_bndrs, eta_body) = collectBinders sat_expr + ; eta_body' <- eval_data2tag_arg eta_body + ; return (mkLams eta_bndrs eta_body') } + where + eval_data2tag_arg :: CpeApp -> UniqSM CpeBody + eval_data2tag_arg app@(fun `App` arg) + | exprIsHNF arg -- Includes nullary constructors + = return app -- The arg is evaluated + | otherwise -- Arg not evaluated, so evaluate it + = do { arg_id <- newVar (exprType arg) + ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding + ; return (Case arg arg_id1 (exprType app) + [(DEFAULT, [], fun `App` Var arg_id1)]) } + + eval_data2tag_arg (Tick t app) -- Scc notes can appear + = do { app' <- eval_data2tag_arg app + ; return (Tick t app') } + + eval_data2tag_arg other -- Should not happen + = pprPanic "eval_data2tag" (ppr other) + +{- +Note [dataToTag magic] +~~~~~~~~~~~~~~~~~~~~~~ +Horrid: we must ensure that the arg of data2TagOp is evaluated + (data2tag x) --> (case x of y -> data2tag y) +(yuk yuk) take into account the lambdas we've now introduced + +How might it not be evaluated? Well, we might have floated it out +of the scope of a `seq`, or dropped the `seq` altogether. + + +************************************************************************ +* * + Simple CoreSyn operations +* * +************************************************************************ +-} + +-- we don't ignore any Tickishes at the moment. +ignoreTickish :: Tickish Id -> Bool +ignoreTickish _ = False + +cpe_ExprIsTrivial :: CoreExpr -> Bool +-- Version that doesn't consider an scc annotation to be trivial. +cpe_ExprIsTrivial (Var _) = True +cpe_ExprIsTrivial (Type _) = True +cpe_ExprIsTrivial (Coercion _) = True +cpe_ExprIsTrivial (Lit _) = True +cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e +cpe_ExprIsTrivial (Tick t e) = not (tickishIsCode t) && cpe_ExprIsTrivial e +cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e +cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body +cpe_ExprIsTrivial _ = False + +{- +-- ----------------------------------------------------------------------------- +-- Eta reduction +-- ----------------------------------------------------------------------------- + +Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~~ +Eta expand to match the arity claimed by the binder Remember, +CorePrep must not change arity + +Eta expansion might not have happened already, because it is done by +the simplifier only when there at least one lambda already. + +NB1:we could refrain when the RHS is trivial (which can happen + for exported things). This would reduce the amount of code + generated (a little) and make things a little words for + code compiled without -O. The case in point is data constructor + wrappers. + +NB2: we have to be careful that the result of etaExpand doesn't + invalidate any of the assumptions that CorePrep is attempting + to establish. One possible cause is eta expanding inside of + an SCC note - we're now careful in etaExpand to make sure the + SCC is pushed inside any new lambdas that are generated. + +Note [Eta expansion and the CorePrep invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It turns out to be much much easier to do eta expansion +*after* the main CorePrep stuff. But that places constraints +on the eta expander: given a CpeRhs, it must return a CpeRhs. + +For example here is what we do not want: + f = /\a -> g (h 3) -- h has arity 2 +After ANFing we get + f = /\a -> let s = h 3 in g s +and now we do NOT want eta expansion to give + f = /\a -> \ y -> (let s = h 3 in g s) y + +Instead CoreArity.etaExpand gives + f = /\a -> \y -> let s = h 3 in g s y +-} + +cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs +cpeEtaExpand arity expr + | arity == 0 = expr + | otherwise = etaExpand arity expr + +{- +-- ----------------------------------------------------------------------------- +-- Eta reduction +-- ----------------------------------------------------------------------------- + +Why try eta reduction? Hasn't the simplifier already done eta? +But the simplifier only eta reduces if that leaves something +trivial (like f, or f Int). But for deLam it would be enough to +get to a partial application: + case x of { p -> \xs. map f xs } + ==> case x of { p -> map f } +-} + +tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr +tryEtaReducePrep bndrs expr@(App _ _) + | ok_to_eta_reduce f + , n_remaining >= 0 + , and (zipWith ok bndrs last_args) + , not (any (`elemVarSet` fvs_remaining) bndrs) + , exprIsHNF remaining_expr -- Don't turn value into a non-value + -- else the behaviour with 'seq' changes + = Just remaining_expr + where + (f, args) = collectArgs expr + remaining_expr = mkApps f remaining_args + fvs_remaining = exprFreeVars remaining_expr + (remaining_args, last_args) = splitAt n_remaining args + n_remaining = length args - length bndrs + + ok bndr (Var arg) = bndr == arg + ok _ _ = False + + -- We can't eta reduce something which must be saturated. + ok_to_eta_reduce (Var f) = not (hasNoBinding f) + ok_to_eta_reduce _ = False -- Safe. ToDo: generalise + +tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body) + | not (any (`elemVarSet` fvs) bndrs) + = case tryEtaReducePrep bndrs body of + Just e -> Just (Let bind e) + Nothing -> Nothing + where + fvs = exprFreeVars r + +tryEtaReducePrep _ _ = Nothing + +{- +************************************************************************ +* * + Floats +* * +************************************************************************ + +Note [Pin demand info on floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pin demand info on floated lets so that we can see the one-shot thunks. +-} + +data FloatingBind + = FloatLet CoreBind -- Rhs of bindings are CpeRhss + -- They are always of lifted type; + -- unlifted ones are done with FloatCase + + | FloatCase + Id CpeBody + Bool -- The bool indicates "ok-for-speculation" + +data Floats = Floats OkToSpec (OrdList FloatingBind) + +instance Outputable FloatingBind where + ppr (FloatLet b) = ppr b + ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r + +instance Outputable Floats where + ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+> + braces (vcat (map ppr (fromOL fs))) + +instance Outputable OkToSpec where + ppr OkToSpec = ptext (sLit "OkToSpec") + ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk") + ppr NotOkToSpec = ptext (sLit "NotOkToSpec") + +-- Can we float these binds out of the rhs of a let? We cache this decision +-- to avoid having to recompute it in a non-linear way when there are +-- deeply nested lets. +data OkToSpec + = OkToSpec -- Lazy bindings of lifted type + | IfUnboxedOk -- A mixture of lazy lifted bindings and n + -- ok-to-speculate unlifted bindings + | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings + +mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind +mkFloat dmd is_unlifted bndr rhs + | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs) + | is_hnf = FloatLet (NonRec bndr rhs) + | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs) + -- See Note [Pin demand info on floats] + where + is_hnf = exprIsHNF rhs + is_strict = isStrictDmd dmd + use_case = is_unlifted || is_strict && not is_hnf + -- Don't make a case for a value binding, + -- even if it's strict. Otherwise we get + -- case (\x -> e) of ...! + +emptyFloats :: Floats +emptyFloats = Floats OkToSpec nilOL + +isEmptyFloats :: Floats -> Bool +isEmptyFloats (Floats _ bs) = isNilOL bs + +wrapBinds :: Floats -> CpeBody -> CpeBody +wrapBinds (Floats _ binds) body + = foldrOL mk_bind body binds + where + mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)] + mk_bind (FloatLet bind) body = Let bind body + +addFloat :: Floats -> FloatingBind -> Floats +addFloat (Floats ok_to_spec floats) new_float + = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) + where + check (FloatLet _) = OkToSpec + check (FloatCase _ _ ok_for_spec) + | ok_for_spec = IfUnboxedOk + | otherwise = NotOkToSpec + -- The ok-for-speculation flag says that it's safe to + -- float this Case out of a let, and thereby do it more eagerly + -- We need the top-level flag because it's never ok to float + -- an unboxed binding to the top level + +unitFloat :: FloatingBind -> Floats +unitFloat = addFloat emptyFloats + +appendFloats :: Floats -> Floats -> Floats +appendFloats (Floats spec1 floats1) (Floats spec2 floats2) + = Floats (combine spec1 spec2) (floats1 `appOL` floats2) + +concatFloats :: [Floats] -> OrdList FloatingBind +concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL + +combine :: OkToSpec -> OkToSpec -> OkToSpec +combine NotOkToSpec _ = NotOkToSpec +combine _ NotOkToSpec = NotOkToSpec +combine IfUnboxedOk _ = IfUnboxedOk +combine _ IfUnboxedOk = IfUnboxedOk +combine _ _ = OkToSpec + +deFloatTop :: Floats -> [CoreBind] +-- For top level only; we don't expect any FloatCases +deFloatTop (Floats _ floats) + = foldrOL get [] floats + where + get (FloatLet b) bs = occurAnalyseRHSs b : bs + get b _ = pprPanic "corePrepPgm" (ppr b) + + -- See Note [Dead code in CorePrep] + occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e) + occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes] + +--------------------------------------------------------------------------- + +canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs) + -- Note [CafInfo and floating] +canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs + | OkToSpec <- ok_to_spec -- Worth trying + , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) + = Just (Floats OkToSpec fs', subst_expr subst rhs) + | otherwise + = Nothing + where + subst_expr = substExpr (text "CorePrep") + + go :: (Subst, OrdList FloatingBind) -> [FloatingBind] + -> Maybe (Subst, OrdList FloatingBind) + + go (subst, fbs_out) [] = Just (subst, fbs_out) + + go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) + | rhs_ok r + = go (subst', fbs_out `snocOL` new_fb) fbs_in + where + (subst', b') = set_nocaf_bndr subst b + new_fb = FloatLet (NonRec b' (subst_expr subst r)) + + go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in) + | all rhs_ok rs + = go (subst', fbs_out `snocOL` new_fb) fbs_in + where + (bs,rs) = unzip prs + (subst', bs') = mapAccumL set_nocaf_bndr subst bs + rs' = map (subst_expr subst') rs + new_fb = FloatLet (Rec (bs' `zip` rs')) + + go _ _ = Nothing -- Encountered a caffy binding + + ------------ + set_nocaf_bndr subst bndr + = (extendIdSubst subst bndr (Var bndr'), bndr') + where + bndr' = bndr `setIdCafInfo` NoCafRefs + + ------------ + rhs_ok :: CoreExpr -> Bool + -- We can only float to top level from a NoCaf thing if + -- the new binding is static. However it can't mention + -- any non-static things or it would *already* be Caffy + rhs_ok = rhsIsStatic platform (\_ -> False) + +wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool +wantFloatNested is_rec strict_or_unlifted floats rhs + = isEmptyFloats floats + || strict_or_unlifted + || (allLazyNested is_rec floats && exprIsHNF rhs) + -- Why the test for allLazyNested? + -- v = f (x `divInt#` y) + -- we don't want to float the case, even if f has arity 2, + -- because floating the case would make it evaluated too early + +allLazyTop :: Floats -> Bool +allLazyTop (Floats OkToSpec _) = True +allLazyTop _ = False + +allLazyNested :: RecFlag -> Floats -> Bool +allLazyNested _ (Floats OkToSpec _) = True +allLazyNested _ (Floats NotOkToSpec _) = False +allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec + +{- +************************************************************************ +* * + Cloning +* * +************************************************************************ +-} + +-- --------------------------------------------------------------------------- +-- The environment +-- --------------------------------------------------------------------------- + +data CorePrepEnv = CPE { + cpe_dynFlags :: DynFlags, + cpe_env :: (IdEnv Id), -- Clone local Ids + cpe_mkIntegerId :: Id, + cpe_integerSDataCon :: Maybe DataCon + } + +lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id +lookupMkIntegerName dflags hsc_env + = guardIntegerUse dflags $ liftM tyThingId $ + initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) + +lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon) +lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of + IntegerGMP -> guardIntegerUse dflags $ liftM Just $ + initTcForLookup hsc_env (tcLookupDataCon integerSDataConName) + IntegerGMP2-> guardIntegerUse dflags $ liftM Just $ + initTcForLookup hsc_env (tcLookupDataCon integerSDataConName) + IntegerSimple -> return Nothing + +-- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName' +guardIntegerUse :: DynFlags -> IO a -> IO a +guardIntegerUse dflags act + | thisPackage dflags == primPackageKey + = return $ panic "Can't use Integer in ghc-prim" + | thisPackage dflags == integerPackageKey + = return $ panic "Can't use Integer in integer-*" + | otherwise = act + +mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv +mkInitialCorePrepEnv dflags hsc_env + = do mkIntegerId <- lookupMkIntegerName dflags hsc_env + integerSDataCon <- lookupIntegerSDataConName dflags hsc_env + return $ CPE { + cpe_dynFlags = dflags, + cpe_env = emptyVarEnv, + cpe_mkIntegerId = mkIntegerId, + cpe_integerSDataCon = integerSDataCon + } + +extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv +extendCorePrepEnv cpe id id' + = cpe { cpe_env = extendVarEnv (cpe_env cpe) id id' } + +extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv +extendCorePrepEnvList cpe prs + = cpe { cpe_env = extendVarEnvList (cpe_env cpe) prs } + +lookupCorePrepEnv :: CorePrepEnv -> Id -> Id +lookupCorePrepEnv cpe id + = case lookupVarEnv (cpe_env cpe) id of + Nothing -> id + Just id' -> id' + +getMkIntegerId :: CorePrepEnv -> Id +getMkIntegerId = cpe_mkIntegerId + +------------------------------------------------------------------------------ +-- Cloning binders +-- --------------------------------------------------------------------------- + +cpCloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var]) +cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs + +cpCloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) +cpCloneBndr env bndr + | isLocalId bndr, not (isCoVar bndr) + = do bndr' <- setVarUnique bndr <$> getUniqueM + + -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings + -- so that we can drop more stuff as dead code. + -- See also Note [Dead code in CorePrep] + let bndr'' = bndr' `setIdUnfolding` noUnfolding + `setIdSpecialisation` emptySpecInfo + return (extendCorePrepEnv env bndr bndr'', bndr'') + + | otherwise -- Top level things, which we don't want + -- to clone, have become GlobalIds by now + -- And we don't clone tyvars, or coercion variables + = return (env, bndr) + + +------------------------------------------------------------------------------ +-- Cloning ccall Ids; each must have a unique name, +-- to give the code generator a handle to hang it on +-- --------------------------------------------------------------------------- + +fiddleCCall :: Id -> UniqSM Id +fiddleCCall id + | isFCallId id = (id `setVarUnique`) <$> getUniqueM + | otherwise = return id + +------------------------------------------------------------------------------ +-- Generating new binders +-- --------------------------------------------------------------------------- + +newVar :: Type -> UniqSM Id +newVar ty + = seqType ty `seq` do + uniq <- getUniqueM + return (mkSysLocal (fsLit "sat") uniq ty) diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs deleted file mode 100644 index 537cc01b43..0000000000 --- a/compiler/coreSyn/CorePrep.lhs +++ /dev/null @@ -1,1211 +0,0 @@ -% -% (c) The University of Glasgow, 1994-2006 -% - -Core pass to saturate constructors and PrimOps - -\begin{code} -{-# LANGUAGE BangPatterns, CPP #-} - -module CorePrep ( - corePrepPgm, corePrepExpr, cvtLitInteger, - lookupMkIntegerName, lookupIntegerSDataConName - ) where - -#include "HsVersions.h" - -import OccurAnal - -import HscTypes -import PrelNames -import CoreUtils -import CoreArity -import CoreFVs -import CoreMonad ( endPassIO, CoreToDo(..) ) -import CoreSyn -import CoreSubst -import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here -import Type -import Literal -import Coercion -import TcEnv -import TcRnMonad -import TyCon -import Demand -import Var -import VarSet -import VarEnv -import Id -import IdInfo -import TysWiredIn -import DataCon -import PrimOp -import BasicTypes -import Module -import UniqSupply -import Maybes -import OrdList -import ErrUtils -import DynFlags -import Util -import Pair -import Outputable -import Platform -import FastString -import Config -import Data.Bits -import Data.List ( mapAccumL ) -import Control.Monad -\end{code} - --- --------------------------------------------------------------------------- --- Overview --- --------------------------------------------------------------------------- - -The goal of this pass is to prepare for code generation. - -1. Saturate constructor and primop applications. - -2. Convert to A-normal form; that is, function arguments - are always variables. - - * Use case for strict arguments: - f E ==> case E of x -> f x - (where f is strict) - - * Use let for non-trivial lazy arguments - f E ==> let x = E in f x - (were f is lazy and x is non-trivial) - -3. Similarly, convert any unboxed lets into cases. - [I'm experimenting with leaving 'ok-for-speculation' - rhss in let-form right up to this point.] - -4. Ensure that *value* lambdas only occur as the RHS of a binding - (The code generator can't deal with anything else.) - Type lambdas are ok, however, because the code gen discards them. - -5. [Not any more; nuked Jun 2002] Do the seq/par munging. - -6. Clone all local Ids. - This means that all such Ids are unique, rather than the - weaker guarantee of no clashes which the simplifier provides. - And that is what the code generator needs. - - We don't clone TyVars or CoVars. The code gen doesn't need that, - and doing so would be tiresome because then we'd need - to substitute in types and coercions. - -7. Give each dynamic CCall occurrence a fresh unique; this is - rather like the cloning step above. - -8. Inject bindings for the "implicit" Ids: - * Constructor wrappers - * Constructor workers - We want curried definitions for all of these in case they - aren't inlined by some caller. - -9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs - -10. Convert (LitInteger i t) into the core representation - for the Integer i. Normally this uses mkInteger, but if - we are using the integer-gmp implementation then there is a - special case where we use the S# constructor for Integers that - are in the range of Int. - -This is all done modulo type applications and abstractions, so that -when type erasure is done for conversion to STG, we don't end up with -any trivial or useless bindings. - - -Invariants -~~~~~~~~~~ -Here is the syntax of the Core produced by CorePrep: - - Trivial expressions - triv ::= lit | var - | triv ty | /\a. triv - | truv co | /\c. triv | triv |> co - - Applications - app ::= lit | var | app triv | app ty | app co | app |> co - - Expressions - body ::= app - | let(rec) x = rhs in body -- Boxed only - | case body of pat -> body - | /\a. body | /\c. body - | body |> co - - Right hand sides (only place where value lambdas can occur) - rhs ::= /\a.rhs | \x.rhs | body - -We define a synonym for each of these non-terminals. Functions -with the corresponding name produce a result in that syntax. - -\begin{code} -type CpeTriv = CoreExpr -- Non-terminal 'triv' -type CpeApp = CoreExpr -- Non-terminal 'app' -type CpeBody = CoreExpr -- Non-terminal 'body' -type CpeRhs = CoreExpr -- Non-terminal 'rhs' -\end{code} - -%************************************************************************ -%* * - Top level stuff -%* * -%************************************************************************ - -\begin{code} -corePrepPgm :: DynFlags -> HscEnv -> CoreProgram -> [TyCon] -> IO CoreProgram -corePrepPgm dflags hsc_env binds data_tycons = do - showPass dflags "CorePrep" - us <- mkSplitUniqSupply 's' - initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env - - let implicit_binds = mkDataConWorkers data_tycons - -- NB: we must feed mkImplicitBinds through corePrep too - -- so that they are suitably cloned and eta-expanded - - binds_out = initUs_ us $ do - floats1 <- corePrepTopBinds initialCorePrepEnv binds - floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds - return (deFloatTop (floats1 `appendFloats` floats2)) - - endPassIO hsc_env alwaysQualify CorePrep binds_out [] - return binds_out - -corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr -corePrepExpr dflags hsc_env expr = do - showPass dflags "CorePrep" - us <- mkSplitUniqSupply 's' - initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env - let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) - dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) - return new_expr - -corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats --- Note [Floating out of top level bindings] -corePrepTopBinds initialCorePrepEnv binds - = go initialCorePrepEnv binds - where - go _ [] = return emptyFloats - go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind - binds' <- go env' binds - return (bind' `appendFloats` binds') - -mkDataConWorkers :: [TyCon] -> [CoreBind] --- See Note [Data constructor workers] --- c.f. Note [Injecting implicit bindings] in TidyPgm -mkDataConWorkers data_tycons - = [ NonRec id (Var id) -- The ice is thin here, but it works - | tycon <- data_tycons, -- CorePrep will eta-expand it - data_con <- tyConDataCons tycon, - let id = dataConWorkId data_con ] -\end{code} - -Note [Floating out of top level bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: we do need to float out of top-level bindings -Consider x = length [True,False] -We want to get - s1 = False : [] - s2 = True : s1 - x = length s2 - -We return a *list* of bindings, because we may start with - x* = f (g y) -where x is demanded, in which case we want to finish with - a = g y - x* = f a -And then x will actually end up case-bound - -Note [CafInfo and floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What happens when we try to float bindings to the top level? At this -point all the CafInfo is supposed to be correct, and we must make certain -that is true of the new top-level bindings. There are two cases -to consider - -a) The top-level binding is marked asCafRefs. In that case we are - basically fine. The floated bindings had better all be lazy lets, - so they can float to top level, but they'll all have HasCafRefs - (the default) which is safe. - -b) The top-level binding is marked NoCafRefs. This really happens - Example. CoreTidy produces - $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah... - Now CorePrep has to eta-expand to - $fApplicativeSTM = let sat = \xy. retry x y - in D:Alternative sat ...blah... - So what we *want* is - sat [NoCafRefs] = \xy. retry x y - $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah... - - So, gruesomely, we must set the NoCafRefs flag on the sat bindings, - *and* substutite the modified 'sat' into the old RHS. - - It should be the case that 'sat' is itself [NoCafRefs] (a value, no - cafs) else the original top-level binding would not itself have been - marked [NoCafRefs]. The DEBUG check in CoreToStg for - consistentCafInfo will find this. - -This is all very gruesome and horrible. It would be better to figure -out CafInfo later, after CorePrep. We'll do that in due course. -Meanwhile this horrible hack works. - - -Note [Data constructor workers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Create any necessary "implicit" bindings for data con workers. We -create the rather strange (non-recursive!) binding - - $wC = \x y -> $wC x y - -i.e. a curried constructor that allocates. This means that we can -treat the worker for a constructor like any other function in the rest -of the compiler. The point here is that CoreToStg will generate a -StgConApp for the RHS, rather than a call to the worker (which would -give a loop). As Lennart says: the ice is thin here, but it works. - -Hmm. Should we create bindings for dictionary constructors? They are -always fully applied, and the bindings are just there to support -partial applications. But it's easier to let them through. - - -Note [Dead code in CorePrep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Imagine that we got an input program like this (see Trac #4962): - - f :: Show b => Int -> (Int, b -> Maybe Int -> Int) - f x = (g True (Just x) + g () (Just x), g) - where - g :: Show a => a -> Maybe Int -> Int - g _ Nothing = x - g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown - -After specialisation and SpecConstr, we would get something like this: - - f :: Show b => Int -> (Int, b -> Maybe Int -> Int) - f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) - where - {-# RULES g $dBool = g$Bool - g $dUnit = g$Unit #-} - g = ... - {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} - g$Bool = ... - {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} - g$Unit = ... - g$Bool_True_Just = ... - g$Unit_Unit_Just = ... - -Note that the g$Bool and g$Unit functions are actually dead code: they -are only kept alive by the occurrence analyser because they are -referred to by the rules of g, which is being kept alive by the fact -that it is used (unspecialised) in the returned pair. - -However, at the CorePrep stage there is no way that the rules for g -will ever fire, and it really seems like a shame to produce an output -program that goes to the trouble of allocating a closure for the -unreachable g$Bool and g$Unit functions. - -The way we fix this is to: - * In cloneBndr, drop all unfoldings/rules - - * In deFloatTop, run a simple dead code analyser on each top-level - RHS to drop the dead local bindings. For that call to OccAnal, we - disable the binder swap, else the occurrence analyser sometimes - introduces new let bindings for cased binders, which lead to the bug - in #5433. - -The reason we don't just OccAnal the whole output of CorePrep is that -the tidier ensures that all top-level binders are GlobalIds, so they -don't show up in the free variables any longer. So if you run the -occurrence analyser on the output of CoreTidy (or later) you e.g. turn -this program: - - Rec { - f = ... f ... - } - -Into this one: - - f = ... f ... - -(Since f is not considered to be free in its own RHS.) - - -%************************************************************************ -%* * - The main code -%* * -%************************************************************************ - -\begin{code} -cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind - -> UniqSM (CorePrepEnv, Floats) -cpeBind top_lvl env (NonRec bndr rhs) - = do { (_, bndr1) <- cpCloneBndr env bndr - ; let dmd = idDemandInfo bndr - is_unlifted = isUnLiftedType (idType bndr) - ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive - dmd - is_unlifted - env bndr1 rhs - ; let new_float = mkFloat dmd is_unlifted bndr2 rhs2 - - -- We want bndr'' in the envt, because it records - -- the evaluated-ness of the binder - ; return (extendCorePrepEnv env bndr bndr2, - addFloat floats new_float) } - -cpeBind top_lvl env (Rec pairs) - = do { let (bndrs,rhss) = unzip pairs - ; (env', bndrs1) <- cpCloneBndrs env (map fst pairs) - ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss - - ; let (floats_s, bndrs2, rhss2) = unzip3 stuff - all_pairs = foldrOL add_float (bndrs2 `zip` rhss2) - (concatFloats floats_s) - ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), - unitFloat (FloatLet (Rec all_pairs))) } - where - -- Flatten all the floats, and the currrent - -- group into a single giant Rec - add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 - add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 - add_float b _ = pprPanic "cpeBind" (ppr b) - ---------------- -cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool - -> CorePrepEnv -> Id -> CoreExpr - -> UniqSM (Floats, Id, CpeRhs) --- Used for all bindings -cpePair top_lvl is_rec dmd is_unlifted env bndr rhs - = do { (floats1, rhs1) <- cpeRhsE env rhs - - -- See if we are allowed to float this stuff out of the RHS - ; (floats2, rhs2) <- float_from_rhs floats1 rhs1 - - -- Make the arity match up - ; (floats3, rhs') - <- if manifestArity rhs1 <= arity - then return (floats2, cpeEtaExpand arity rhs2) - else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) - -- Note [Silly extra arguments] - (do { v <- newVar (idType bndr) - ; let float = mkFloat topDmd False v rhs2 - ; return ( addFloat floats2 float - , cpeEtaExpand arity (Var v)) }) - - -- Record if the binder is evaluated - -- and otherwise trim off the unfolding altogether - -- It's not used by the code generator; getting rid of it reduces - -- heap usage and, since we may be changing uniques, we'd have - -- to substitute to keep it right - ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding - | otherwise = bndr `setIdUnfolding` noUnfolding - - ; return (floats3, bndr', rhs') } - where - is_strict_or_unlifted = (isStrictDmd dmd) || is_unlifted - - platform = targetPlatform (cpe_dynFlags env) - - arity = idArity bndr -- We must match this arity - - --------------------- - float_from_rhs floats rhs - | isEmptyFloats floats = return (emptyFloats, rhs) - | isTopLevel top_lvl = float_top floats rhs - | otherwise = float_nested floats rhs - - --------------------- - float_nested floats rhs - | wantFloatNested is_rec is_strict_or_unlifted floats rhs - = return (floats, rhs) - | otherwise = dont_float floats rhs - - --------------------- - float_top floats rhs -- Urhgh! See Note [CafInfo and floating] - | mayHaveCafRefs (idCafInfo bndr) - , allLazyTop floats - = return (floats, rhs) - - -- So the top-level binding is marked NoCafRefs - | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs - = return (floats', rhs') - - | otherwise - = dont_float floats rhs - - --------------------- - dont_float floats rhs - -- Non-empty floats, but do not want to float from rhs - -- So wrap the rhs in the floats - -- But: rhs1 might have lambdas, and we can't - -- put them inside a wrapBinds - = do { body <- rhsToBodyNF rhs - ; return (emptyFloats, wrapBinds floats body) } - -{- Note [Silly extra arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we had this - f{arity=1} = \x\y. e -We *must* match the arity on the Id, so we have to generate - f' = \x\y. e - f = \x. f' x - -It's a bizarre case: why is the arity on the Id wrong? Reason -(in the days of __inline_me__): - f{arity=0} = __inline_me__ (let v = expensive in \xy. e) -When InlineMe notes go away this won't happen any more. But -it seems good for CorePrep to be robust. --} - --- --------------------------------------------------------------------------- --- CpeRhs: produces a result satisfying CpeRhs --- --------------------------------------------------------------------------- - -cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- If --- e ===> (bs, e') --- then --- e = let bs in e' (semantically, that is!) --- --- For example --- f (g x) ===> ([v = g x], f v) - -cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) -cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) -cpeRhsE env (Lit (LitInteger i _)) - = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env) - (cpe_integerSDataCon env) i) -cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) -cpeRhsE env expr@(Var {}) = cpeApp env expr - -cpeRhsE env (Var f `App` _ `App` arg) - | f `hasKey` lazyIdKey -- Replace (lazy a) by a - = cpeRhsE env arg -- See Note [lazyId magic] in MkId - -cpeRhsE env expr@(App {}) = cpeApp env expr - -cpeRhsE env (Let bind expr) - = do { (env', new_binds) <- cpeBind NotTopLevel env bind - ; (floats, body) <- cpeRhsE env' expr - ; return (new_binds `appendFloats` floats, body) } - -cpeRhsE env (Tick tickish expr) - | ignoreTickish tickish - = cpeRhsE env expr - | otherwise -- Just SCCs actually - = do { body <- cpeBodyNF env expr - ; return (emptyFloats, Tick tickish' body) } - where - tickish' | Breakpoint n fvs <- tickish - = Breakpoint n (map (lookupCorePrepEnv env) fvs) - | otherwise - = tickish - -cpeRhsE env (Cast expr co) - = do { (floats, expr') <- cpeRhsE env expr - ; return (floats, Cast expr' co) } - -cpeRhsE env expr@(Lam {}) - = do { let (bndrs,body) = collectBinders expr - ; (env', bndrs') <- cpCloneBndrs env bndrs - ; body' <- cpeBodyNF env' body - ; return (emptyFloats, mkLams bndrs' body') } - -cpeRhsE env (Case scrut bndr ty alts) - = do { (floats, scrut') <- cpeBody env scrut - ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding - -- Record that the case binder is evaluated in the alternatives - ; (env', bndr2) <- cpCloneBndr env bndr1 - ; alts' <- mapM (sat_alt env') alts - ; return (floats, Case scrut' bndr2 ty alts') } - where - sat_alt env (con, bs, rhs) - = do { (env2, bs') <- cpCloneBndrs env bs - ; rhs' <- cpeBodyNF env2 rhs - ; return (con, bs', rhs') } - -cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr --- Here we convert a literal Integer to the low-level --- represenation. Exactly how we do this depends on the --- library that implements Integer. If it's GMP we --- use the S# data constructor for small literals. --- See Note [Integer literals] in Literal -cvtLitInteger dflags _ (Just sdatacon) i - | inIntRange dflags i -- Special case for small integers - = mkConApp sdatacon [Lit (mkMachInt dflags i)] - -cvtLitInteger dflags mk_integer _ i - = mkApps (Var mk_integer) [isNonNegative, ints] - where isNonNegative = if i < 0 then mkConApp falseDataCon [] - else mkConApp trueDataCon [] - ints = mkListExpr intTy (f (abs i)) - f 0 = [] - f x = let low = x .&. mask - high = x `shiftR` bits - in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high - bits = 31 - mask = 2 ^ bits - 1 - --- --------------------------------------------------------------------------- --- CpeBody: produces a result satisfying CpeBody --- --------------------------------------------------------------------------- - -cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody -cpeBodyNF env expr - = do { (floats, body) <- cpeBody env expr - ; return (wrapBinds floats body) } - --------- -cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) -cpeBody env expr - = do { (floats1, rhs) <- cpeRhsE env expr - ; (floats2, body) <- rhsToBody rhs - ; return (floats1 `appendFloats` floats2, body) } - --------- -rhsToBodyNF :: CpeRhs -> UniqSM CpeBody -rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs - ; return (wrapBinds floats body) } - --------- -rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) --- Remove top level lambdas by let-binding - -rhsToBody (Tick t expr) - | not (tickishScoped t) -- we can only float out of non-scoped annotations - = do { (floats, expr') <- rhsToBody expr - ; return (floats, Tick t expr') } - -rhsToBody (Cast e co) - -- You can get things like - -- case e of { p -> coerce t (\s -> ...) } - = do { (floats, e') <- rhsToBody e - ; return (floats, Cast e' co) } - -rhsToBody expr@(Lam {}) - | Just no_lam_result <- tryEtaReducePrep bndrs body - = return (emptyFloats, no_lam_result) - | all isTyVar bndrs -- Type lambdas are ok - = return (emptyFloats, expr) - | otherwise -- Some value lambdas - = do { fn <- newVar (exprType expr) - ; let rhs = cpeEtaExpand (exprArity expr) expr - float = FloatLet (NonRec fn rhs) - ; return (unitFloat float, Var fn) } - where - (bndrs,body) = collectBinders expr - -rhsToBody expr = return (emptyFloats, expr) - - - --- --------------------------------------------------------------------------- --- CpeApp: produces a result satisfying CpeApp --- --------------------------------------------------------------------------- - -cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops -cpeApp env expr - = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0 - ; MASSERT(null ss) -- make sure we used all the strictness info - - -- Now deal with the function - ; case head of - Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth - ; return (floats, sat_app) } - _other -> return (floats, app) } - - where - -- Deconstruct and rebuild the application, floating any non-atomic - -- arguments to the outside. We collect the type of the expression, - -- the head of the application, and the number of actual value arguments, - -- all of which are used to possibly saturate this application if it - -- has a constructor or primop at the head. - - collect_args - :: CoreExpr - -> Int -- Current app depth - -> UniqSM (CpeApp, -- The rebuilt expression - (CoreExpr,Int), -- The head of the application, - -- and no. of args it was applied to - Type, -- Type of the whole expr - Floats, -- Any floats we pulled out - [Demand]) -- Remaining argument demands - - collect_args (App fun arg@(Type arg_ty)) depth - = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth - ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) } - - collect_args (App fun arg@(Coercion arg_co)) depth - = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth - ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) } - - collect_args (App fun arg) depth - = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1) - ; let - (ss1, ss_rest) = case ss of - (ss1:ss_rest) -> (ss1, ss_rest) - [] -> (topDmd, []) - (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $ - splitFunTy_maybe fun_ty - - ; (fs, arg') <- cpeArg env ss1 arg arg_ty - ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) } - - collect_args (Var v) depth - = do { v1 <- fiddleCCall v - ; let v2 = lookupCorePrepEnv env v1 - ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) } - where - stricts = case idStrictness v of - StrictSig (DmdType _ demands _) - | listLengthCmp demands depth /= GT -> demands - -- length demands <= depth - | otherwise -> [] - -- If depth < length demands, then we have too few args to - -- satisfy strictness info so we have to ignore all the - -- strictness info, e.g. + (error "urk") - -- Here, we can't evaluate the arg strictly, because this - -- partial application might be seq'd - - collect_args (Cast fun co) depth - = do { let Pair _ty1 ty2 = coercionKind co - ; (fun', hd, _, floats, ss) <- collect_args fun depth - ; return (Cast fun' co, hd, ty2, floats, ss) } - - collect_args (Tick tickish fun) depth - | ignoreTickish tickish -- Drop these notes altogether - = collect_args fun depth -- They aren't used by the code generator - - -- N-variable fun, better let-bind it - collect_args fun depth - = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty - -- The evalDmd says that it's sure to be evaluated, - -- so we'll end up case-binding it - ; return (fun', (fun', depth), ty, fun_floats, []) } - where - ty = exprType fun - --- --------------------------------------------------------------------------- --- CpeArg: produces a result satisfying CpeArg --- --------------------------------------------------------------------------- - --- This is where we arrange that a non-trivial argument is let-bound -cpeArg :: CorePrepEnv -> Demand - -> CoreArg -> Type -> UniqSM (Floats, CpeTriv) -cpeArg env dmd arg arg_ty - = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda - ; (floats2, arg2) <- if want_float floats1 arg1 - then return (floats1, arg1) - else do { body1 <- rhsToBodyNF arg1 - ; return (emptyFloats, wrapBinds floats1 body1) } - -- Else case: arg1 might have lambdas, and we can't - -- put them inside a wrapBinds - - ; if cpe_ExprIsTrivial arg2 -- Do not eta expand a trivial argument - then return (floats2, arg2) - else do - { v <- newVar arg_ty - ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 - arg_float = mkFloat dmd is_unlifted v arg3 - ; return (addFloat floats2 arg_float, varToCoreExpr v) } } - where - is_unlifted = isUnLiftedType arg_ty - is_strict = isStrictDmd dmd - want_float = wantFloatNested NonRecursive (is_strict || is_unlifted) -\end{code} - -Note [Floating unlifted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider C (let v* = expensive in v) - -where the "*" indicates "will be demanded". Usually v will have been -inlined by now, but let's suppose it hasn't (see Trac #2756). Then we -do *not* want to get - - let v* = expensive in C v - -because that has different strictness. Hence the use of 'allLazy'. -(NB: the let v* turns into a FloatCase, in mkLocalNonRec.) - - ------------------------------------------------------------------------------- --- Building the saturated syntax --- --------------------------------------------------------------------------- - -maybeSaturate deals with saturating primops and constructors -The type is the type of the entire application - -\begin{code} -maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs -maybeSaturate fn expr n_args - | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg - -- A gruesome special case - = saturateDataToTag sat_expr - - | hasNoBinding fn -- There's no binding - = return sat_expr - - | otherwise - = return expr - where - fn_arity = idArity fn - excess_arity = fn_arity - n_args - sat_expr = cpeEtaExpand excess_arity expr - -------------- -saturateDataToTag :: CpeApp -> UniqSM CpeApp --- See Note [dataToTag magic] -saturateDataToTag sat_expr - = do { let (eta_bndrs, eta_body) = collectBinders sat_expr - ; eta_body' <- eval_data2tag_arg eta_body - ; return (mkLams eta_bndrs eta_body') } - where - eval_data2tag_arg :: CpeApp -> UniqSM CpeBody - eval_data2tag_arg app@(fun `App` arg) - | exprIsHNF arg -- Includes nullary constructors - = return app -- The arg is evaluated - | otherwise -- Arg not evaluated, so evaluate it - = do { arg_id <- newVar (exprType arg) - ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding - ; return (Case arg arg_id1 (exprType app) - [(DEFAULT, [], fun `App` Var arg_id1)]) } - - eval_data2tag_arg (Tick t app) -- Scc notes can appear - = do { app' <- eval_data2tag_arg app - ; return (Tick t app') } - - eval_data2tag_arg other -- Should not happen - = pprPanic "eval_data2tag" (ppr other) -\end{code} - -Note [dataToTag magic] -~~~~~~~~~~~~~~~~~~~~~~ -Horrid: we must ensure that the arg of data2TagOp is evaluated - (data2tag x) --> (case x of y -> data2tag y) -(yuk yuk) take into account the lambdas we've now introduced - -How might it not be evaluated? Well, we might have floated it out -of the scope of a `seq`, or dropped the `seq` altogether. - - -%************************************************************************ -%* * - Simple CoreSyn operations -%* * -%************************************************************************ - -\begin{code} --- we don't ignore any Tickishes at the moment. -ignoreTickish :: Tickish Id -> Bool -ignoreTickish _ = False - -cpe_ExprIsTrivial :: CoreExpr -> Bool --- Version that doesn't consider an scc annotation to be trivial. -cpe_ExprIsTrivial (Var _) = True -cpe_ExprIsTrivial (Type _) = True -cpe_ExprIsTrivial (Coercion _) = True -cpe_ExprIsTrivial (Lit _) = True -cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e -cpe_ExprIsTrivial (Tick t e) = not (tickishIsCode t) && cpe_ExprIsTrivial e -cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e -cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body -cpe_ExprIsTrivial _ = False -\end{code} - --- ----------------------------------------------------------------------------- --- Eta reduction --- ----------------------------------------------------------------------------- - -Note [Eta expansion] -~~~~~~~~~~~~~~~~~~~~~ -Eta expand to match the arity claimed by the binder Remember, -CorePrep must not change arity - -Eta expansion might not have happened already, because it is done by -the simplifier only when there at least one lambda already. - -NB1:we could refrain when the RHS is trivial (which can happen - for exported things). This would reduce the amount of code - generated (a little) and make things a little words for - code compiled without -O. The case in point is data constructor - wrappers. - -NB2: we have to be careful that the result of etaExpand doesn't - invalidate any of the assumptions that CorePrep is attempting - to establish. One possible cause is eta expanding inside of - an SCC note - we're now careful in etaExpand to make sure the - SCC is pushed inside any new lambdas that are generated. - -Note [Eta expansion and the CorePrep invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It turns out to be much much easier to do eta expansion -*after* the main CorePrep stuff. But that places constraints -on the eta expander: given a CpeRhs, it must return a CpeRhs. - -For example here is what we do not want: - f = /\a -> g (h 3) -- h has arity 2 -After ANFing we get - f = /\a -> let s = h 3 in g s -and now we do NOT want eta expansion to give - f = /\a -> \ y -> (let s = h 3 in g s) y - -Instead CoreArity.etaExpand gives - f = /\a -> \y -> let s = h 3 in g s y - -\begin{code} -cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs -cpeEtaExpand arity expr - | arity == 0 = expr - | otherwise = etaExpand arity expr -\end{code} - --- ----------------------------------------------------------------------------- --- Eta reduction --- ----------------------------------------------------------------------------- - -Why try eta reduction? Hasn't the simplifier already done eta? -But the simplifier only eta reduces if that leaves something -trivial (like f, or f Int). But for deLam it would be enough to -get to a partial application: - case x of { p -> \xs. map f xs } - ==> case x of { p -> map f } - -\begin{code} -tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr -tryEtaReducePrep bndrs expr@(App _ _) - | ok_to_eta_reduce f - , n_remaining >= 0 - , and (zipWith ok bndrs last_args) - , not (any (`elemVarSet` fvs_remaining) bndrs) - , exprIsHNF remaining_expr -- Don't turn value into a non-value - -- else the behaviour with 'seq' changes - = Just remaining_expr - where - (f, args) = collectArgs expr - remaining_expr = mkApps f remaining_args - fvs_remaining = exprFreeVars remaining_expr - (remaining_args, last_args) = splitAt n_remaining args - n_remaining = length args - length bndrs - - ok bndr (Var arg) = bndr == arg - ok _ _ = False - - -- We can't eta reduce something which must be saturated. - ok_to_eta_reduce (Var f) = not (hasNoBinding f) - ok_to_eta_reduce _ = False -- Safe. ToDo: generalise - -tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body) - | not (any (`elemVarSet` fvs) bndrs) - = case tryEtaReducePrep bndrs body of - Just e -> Just (Let bind e) - Nothing -> Nothing - where - fvs = exprFreeVars r - -tryEtaReducePrep _ _ = Nothing -\end{code} - - -%************************************************************************ -%* * - Floats -%* * -%************************************************************************ - -Note [Pin demand info on floats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pin demand info on floated lets so that we can see the one-shot thunks. - -\begin{code} -data FloatingBind - = FloatLet CoreBind -- Rhs of bindings are CpeRhss - -- They are always of lifted type; - -- unlifted ones are done with FloatCase - - | FloatCase - Id CpeBody - Bool -- The bool indicates "ok-for-speculation" - -data Floats = Floats OkToSpec (OrdList FloatingBind) - -instance Outputable FloatingBind where - ppr (FloatLet b) = ppr b - ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r - -instance Outputable Floats where - ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+> - braces (vcat (map ppr (fromOL fs))) - -instance Outputable OkToSpec where - ppr OkToSpec = ptext (sLit "OkToSpec") - ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk") - ppr NotOkToSpec = ptext (sLit "NotOkToSpec") - --- Can we float these binds out of the rhs of a let? We cache this decision --- to avoid having to recompute it in a non-linear way when there are --- deeply nested lets. -data OkToSpec - = OkToSpec -- Lazy bindings of lifted type - | IfUnboxedOk -- A mixture of lazy lifted bindings and n - -- ok-to-speculate unlifted bindings - | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings - -mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind -mkFloat dmd is_unlifted bndr rhs - | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs) - | is_hnf = FloatLet (NonRec bndr rhs) - | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs) - -- See Note [Pin demand info on floats] - where - is_hnf = exprIsHNF rhs - is_strict = isStrictDmd dmd - use_case = is_unlifted || is_strict && not is_hnf - -- Don't make a case for a value binding, - -- even if it's strict. Otherwise we get - -- case (\x -> e) of ...! - -emptyFloats :: Floats -emptyFloats = Floats OkToSpec nilOL - -isEmptyFloats :: Floats -> Bool -isEmptyFloats (Floats _ bs) = isNilOL bs - -wrapBinds :: Floats -> CpeBody -> CpeBody -wrapBinds (Floats _ binds) body - = foldrOL mk_bind body binds - where - mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)] - mk_bind (FloatLet bind) body = Let bind body - -addFloat :: Floats -> FloatingBind -> Floats -addFloat (Floats ok_to_spec floats) new_float - = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) - where - check (FloatLet _) = OkToSpec - check (FloatCase _ _ ok_for_spec) - | ok_for_spec = IfUnboxedOk - | otherwise = NotOkToSpec - -- The ok-for-speculation flag says that it's safe to - -- float this Case out of a let, and thereby do it more eagerly - -- We need the top-level flag because it's never ok to float - -- an unboxed binding to the top level - -unitFloat :: FloatingBind -> Floats -unitFloat = addFloat emptyFloats - -appendFloats :: Floats -> Floats -> Floats -appendFloats (Floats spec1 floats1) (Floats spec2 floats2) - = Floats (combine spec1 spec2) (floats1 `appOL` floats2) - -concatFloats :: [Floats] -> OrdList FloatingBind -concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL - -combine :: OkToSpec -> OkToSpec -> OkToSpec -combine NotOkToSpec _ = NotOkToSpec -combine _ NotOkToSpec = NotOkToSpec -combine IfUnboxedOk _ = IfUnboxedOk -combine _ IfUnboxedOk = IfUnboxedOk -combine _ _ = OkToSpec - -deFloatTop :: Floats -> [CoreBind] --- For top level only; we don't expect any FloatCases -deFloatTop (Floats _ floats) - = foldrOL get [] floats - where - get (FloatLet b) bs = occurAnalyseRHSs b : bs - get b _ = pprPanic "corePrepPgm" (ppr b) - - -- See Note [Dead code in CorePrep] - occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e) - occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes] - ---------------------------------------------------------------------------- - -canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs) - -- Note [CafInfo and floating] -canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs - | OkToSpec <- ok_to_spec -- Worth trying - , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) - = Just (Floats OkToSpec fs', subst_expr subst rhs) - | otherwise - = Nothing - where - subst_expr = substExpr (text "CorePrep") - - go :: (Subst, OrdList FloatingBind) -> [FloatingBind] - -> Maybe (Subst, OrdList FloatingBind) - - go (subst, fbs_out) [] = Just (subst, fbs_out) - - go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) - | rhs_ok r - = go (subst', fbs_out `snocOL` new_fb) fbs_in - where - (subst', b') = set_nocaf_bndr subst b - new_fb = FloatLet (NonRec b' (subst_expr subst r)) - - go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in) - | all rhs_ok rs - = go (subst', fbs_out `snocOL` new_fb) fbs_in - where - (bs,rs) = unzip prs - (subst', bs') = mapAccumL set_nocaf_bndr subst bs - rs' = map (subst_expr subst') rs - new_fb = FloatLet (Rec (bs' `zip` rs')) - - go _ _ = Nothing -- Encountered a caffy binding - - ------------ - set_nocaf_bndr subst bndr - = (extendIdSubst subst bndr (Var bndr'), bndr') - where - bndr' = bndr `setIdCafInfo` NoCafRefs - - ------------ - rhs_ok :: CoreExpr -> Bool - -- We can only float to top level from a NoCaf thing if - -- the new binding is static. However it can't mention - -- any non-static things or it would *already* be Caffy - rhs_ok = rhsIsStatic platform (\_ -> False) - -wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool -wantFloatNested is_rec strict_or_unlifted floats rhs - = isEmptyFloats floats - || strict_or_unlifted - || (allLazyNested is_rec floats && exprIsHNF rhs) - -- Why the test for allLazyNested? - -- v = f (x `divInt#` y) - -- we don't want to float the case, even if f has arity 2, - -- because floating the case would make it evaluated too early - -allLazyTop :: Floats -> Bool -allLazyTop (Floats OkToSpec _) = True -allLazyTop _ = False - -allLazyNested :: RecFlag -> Floats -> Bool -allLazyNested _ (Floats OkToSpec _) = True -allLazyNested _ (Floats NotOkToSpec _) = False -allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec -\end{code} - - -%************************************************************************ -%* * - Cloning -%* * -%************************************************************************ - -\begin{code} --- --------------------------------------------------------------------------- --- The environment --- --------------------------------------------------------------------------- - -data CorePrepEnv = CPE { - cpe_dynFlags :: DynFlags, - cpe_env :: (IdEnv Id), -- Clone local Ids - cpe_mkIntegerId :: Id, - cpe_integerSDataCon :: Maybe DataCon - } - -lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id -lookupMkIntegerName dflags hsc_env - = guardIntegerUse dflags $ liftM tyThingId $ - initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) - -lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon) -lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of - IntegerGMP -> guardIntegerUse dflags $ liftM Just $ - initTcForLookup hsc_env (tcLookupDataCon integerSDataConName) - IntegerGMP2-> guardIntegerUse dflags $ liftM Just $ - initTcForLookup hsc_env (tcLookupDataCon integerSDataConName) - IntegerSimple -> return Nothing - --- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName' -guardIntegerUse :: DynFlags -> IO a -> IO a -guardIntegerUse dflags act - | thisPackage dflags == primPackageKey - = return $ panic "Can't use Integer in ghc-prim" - | thisPackage dflags == integerPackageKey - = return $ panic "Can't use Integer in integer-*" - | otherwise = act - -mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv -mkInitialCorePrepEnv dflags hsc_env - = do mkIntegerId <- lookupMkIntegerName dflags hsc_env - integerSDataCon <- lookupIntegerSDataConName dflags hsc_env - return $ CPE { - cpe_dynFlags = dflags, - cpe_env = emptyVarEnv, - cpe_mkIntegerId = mkIntegerId, - cpe_integerSDataCon = integerSDataCon - } - -extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv -extendCorePrepEnv cpe id id' - = cpe { cpe_env = extendVarEnv (cpe_env cpe) id id' } - -extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv -extendCorePrepEnvList cpe prs - = cpe { cpe_env = extendVarEnvList (cpe_env cpe) prs } - -lookupCorePrepEnv :: CorePrepEnv -> Id -> Id -lookupCorePrepEnv cpe id - = case lookupVarEnv (cpe_env cpe) id of - Nothing -> id - Just id' -> id' - -getMkIntegerId :: CorePrepEnv -> Id -getMkIntegerId = cpe_mkIntegerId - ------------------------------------------------------------------------------- --- Cloning binders --- --------------------------------------------------------------------------- - -cpCloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var]) -cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs - -cpCloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) -cpCloneBndr env bndr - | isLocalId bndr, not (isCoVar bndr) - = do bndr' <- setVarUnique bndr <$> getUniqueM - - -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings - -- so that we can drop more stuff as dead code. - -- See also Note [Dead code in CorePrep] - let bndr'' = bndr' `setIdUnfolding` noUnfolding - `setIdSpecialisation` emptySpecInfo - return (extendCorePrepEnv env bndr bndr'', bndr'') - - | otherwise -- Top level things, which we don't want - -- to clone, have become GlobalIds by now - -- And we don't clone tyvars, or coercion variables - = return (env, bndr) - - ------------------------------------------------------------------------------- --- Cloning ccall Ids; each must have a unique name, --- to give the code generator a handle to hang it on --- --------------------------------------------------------------------------- - -fiddleCCall :: Id -> UniqSM Id -fiddleCCall id - | isFCallId id = (id `setVarUnique`) <$> getUniqueM - | otherwise = return id - ------------------------------------------------------------------------------- --- Generating new binders --- --------------------------------------------------------------------------- - -newVar :: Type -> UniqSM Id -newVar ty - = seqType ty `seq` do - uniq <- getUniqueM - return (mkSysLocal (fsLit "sat") uniq ty) -\end{code} diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs new file mode 100644 index 0000000000..82e18ca5ba --- /dev/null +++ b/compiler/coreSyn/CoreSubst.hs @@ -0,0 +1,1408 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utility functions on @Core@ syntax +-} + +{-# LANGUAGE CPP #-} +module CoreSubst ( + -- * 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, lookupTvSubst, lookupCvSubst, substIdOcc, + substTickish, substVarSet, + + -- ** Operations on substitutions + emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, + extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList, + extendCvSubst, extendCvSubstList, + extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, + addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, + isInScope, setInScope, + delBndr, delBndrs, + + -- ** Substituting and cloning binders + substBndr, substBndrs, substRecBndrs, + cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + + -- ** Simple expression optimiser + simpleOptPgm, simpleOptExpr, simpleOptExprWith, + exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, + ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreFVs +import CoreUtils +import Literal ( Literal(MachStr) ) +import qualified Data.ByteString as BS +import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) + +import qualified Type +import qualified Coercion + + -- We are defining local versions +import Type hiding ( substTy, extendTvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr ) + +import TyCon ( tyConArity ) +import DataCon +import PrelNames ( eqBoxDataConKey, coercibleDataConKey, unpackCStringIdKey + , unpackCStringUtf8IdKey ) +import OptCoercion ( optCoercion ) +import PprCore ( pprCoreBindings, pprRules ) +import Module ( Module ) +import VarSet +import VarEnv +import Id +import Name ( Name ) +import Var +import IdInfo +import Unique +import UniqSupply +import Maybes +import ErrUtils +import DynFlags +import BasicTypes ( isAlwaysActive ) +import Util +import Pair +import Outputable +import PprCore () -- Instances +import FastString + +import Data.List + +import TysWiredIn + +{- +************************************************************************ +* * +\subsection{Substitutions} +* * +************************************************************************ +-} + +-- | A substitution environment, containing both 'Id' and 'TyVar' substitutions. +-- +-- Some invariants apply to how you use the substitution: +-- +-- 1. #in_scope_invariant# The in-scope set contains at least those 'Id's and 'TyVar's that will be in scope /after/ +-- applying the substitution to a term. Precisely, the in-scope set must be a superset of the free vars of the +-- substitution range that might possibly clash with locally-bound variables in the thing being substituted in. +-- +-- 2. #apply_once# You may apply the substitution only /once/ +-- +-- There are various ways of setting up the in-scope set such that the first of these invariants hold: +-- +-- * Arrange that the in-scope set really is all the things in scope +-- +-- * Arrange that it's the free vars of the range of the substitution +-- +-- * Make it empty, if you know that all the free vars of the substitution are fresh, and hence can't possibly clash +data Subst + = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ + -- applying the substitution + IdSubstEnv -- Substitution for Ids + TvSubstEnv -- Substitution from TyVars to Types + CvSubstEnv -- Substitution from CoVars to Coercions + + -- INVARIANT 1: See #in_scope_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 TvSubst] with Type.TvSubstEnv + +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 the TvSubstEnv and IdSubstEnv are both 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 + +---------------------------- +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 "CoreSubst#in_scope_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 the "CoreSubst#in_scope_invariant" is true 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 = 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 = Subst in_scope (extendVarEnvList ids prs) tvs cvs + +-- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is +-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this +extendTvSubst :: Subst -> TyVar -> Type -> Subst +extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEnv tvs v r) cvs + +-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' +extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst +extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs + +-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is +-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this +extendCvSubst :: Subst -> CoVar -> Coercion -> Subst +extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r) + +-- | Adds multiple 'CoVar' -> 'Coercion' substitutions to the +-- 'Subst': see also 'extendCvSubst' +extendCvSubstList :: Subst -> [(CoVar,Coercion)] -> Subst +extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs) + +-- | Add a substitution appropriate to the thing being substituted +-- (whether an expression, type, or coercion). See also +-- 'extendIdSubst', 'extendTvSubst', and '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, ptext (sLit "CoreSubst.lookupIdSubst") <+> doc <+> ppr v + $$ ppr in_scope) + Var v + +-- | Find the substitution for a 'TyVar' in the 'Subst' +lookupTvSubst :: Subst -> TyVar -> Type +lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v + +-- | Find the coercion substitution for a 'CoVar' in the 'Subst' +lookupCvSubst :: Subst -> CoVar -> Coercion +lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) 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) + = ptext (sLit " braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope)))) + $$ ptext (sLit " IdSubst =") <+> ppr ids + $$ ptext (sLit " TvSubst =") <+> ppr tvs + $$ ptext (sLit " CvSubst =") <+> ppr cvs + <> char '>' + +{- +************************************************************************ +* * + Substituting expressions +* * +************************************************************************ +-} + +-- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only +-- apply the substitution /once/: see "CoreSubst#apply_once" +-- +-- 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 subst orig_expr + +substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr +substExpr _doc subst orig_expr = subst_expr subst orig_expr + +subst_expr :: Subst -> CoreExpr -> CoreExpr +subst_expr subst expr + = go expr + where + go (Var v) = lookupIdSubst (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) = Tick (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 subst' body) + where + (subst', bndr') = substBndr subst bndr + + go (Let bind body) = Let bind' (subst_expr 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 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 subst') rhss + +substBind subst (NonRec bndr rhs) = (subst', NonRec bndr' (subst_expr 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 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 || + isEmptyVarSet (Type.tyVarsOfType 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 TvSubst. +-} + +substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) +substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv + = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of + (TvSubst in_scope' tv_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 (TvSubst in_scope tv_env) tv uniq of + (TvSubst in_scope' tv_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 (CvSubst in_scope tv_env cv_env) cv of + (CvSubst 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.substTy (getTvSubst subst) ty + +getTvSubst :: Subst -> TvSubst +getTvSubst (Subst in_scope _ tenv _) = TvSubst in_scope tenv + +getCvSubst :: Subst -> CvSubst +getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv + +-- | See 'Coercion.substCo' +substCo :: Subst -> Coercion -> Coercion +substCo subst co = Coercion.substCo (getCvSubst subst) co + +{- +************************************************************************ +* * +\section{IdInfo substitution} +* * +************************************************************************ +-} + +substIdType :: Subst -> Id -> Id +substIdType subst@(Subst _ _ tv_env cv_env) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id + | otherwise = setIdType id (substTy subst old_ty) + -- The tyVarsOfType 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 `setSpecInfo` substSpec subst new_id old_rules + `setUnfoldingInfo` substUnfolding subst old_unf) + where + old_rules = specInfo info + old_unf = unfoldingInfo info + nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding 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 -> SpecInfo -> SpecInfo +substSpec subst new_id (SpecInfo rules rhs_fvs) + = seqSpecInfo new_spec `seq` new_spec + where + subst_ru_fn = const (idName new_id) + new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules) + (substVarSet 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 (text "subst-rule" <+> ppr fn_name) subst') args, + ru_rhs = simpleOptExprWith subst' rhs } + -- Do simple optimisation on RHS, in case substitution lets + -- you improve it. The real simplifier never gets to look at it. + where + (subst', bndrs') = substBndrs subst bndrs + +------------------ +substVects :: Subst -> [CoreVect] -> [CoreVect] +substVects subst = map (substVect subst) + +------------------ +substVect :: Subst -> CoreVect -> CoreVect +substVect subst (Vect v rhs) = Vect v (simpleOptExprWith subst rhs) +substVect _subst vd@(NoVect _) = vd +substVect _subst vd@(VectType _ _ _) = vd +substVect _subst vd@(VectClass _) = vd +substVect _subst vd@(VectInst _) = vd + +------------------ +substVarSet :: Subst -> VarSet -> VarSet +substVarSet subst fvs + = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs + where + subst_fv subst fv + | isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv) + | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv) + +------------------ +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 [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 Coverage.mkTickish. +Breakpoints can't handle free variables with unlifted types anyway. +-} + +{- +Note [Worker inlining] +~~~~~~~~~~~~~~~~~~~~~~ +A worker can get sustituted 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. + + +************************************************************************ +* * + The Very Simple Optimiser +* * +************************************************************************ + +Note [Optimise coercion boxes agressively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The simple expression optimiser needs to deal with Eq# boxes as follows: + 1. If the result of optimising the RHS of a non-recursive binding is an + Eq# box, that box is substituted rather than turned into a let, just as + if it were trivial. + let eqv = Eq# co in e ==> e[Eq# co/eqv] + + 2. If the result of optimising a case scrutinee is a Eq# box and the case + deconstructs it in a trivial way, we evaluate the case then and there. + case Eq# co of Eq# cov -> e ==> e[co/cov] + +We do this for two reasons: + + 1. Bindings/case scrutinisation of this form is often created by the + evidence-binding mechanism and we need them to be inlined to be able + desugar RULE LHSes that involve equalities (see e.g. T2291) + + 2. The test T4356 fails Lint because it creates a coercion between types + of kind (* -> * -> *) and (?? -> ? -> *), which differ. If we do this + inlining agressively we can collapse away the intermediate coercion between + these two types and hence pass Lint again. (This is a sort of a hack.) + +In fact, our implementation uses slightly liberalised versions of the second rule +rule so that the optimisations are a bit more generally applicable. Precisely: + 2a. We reduce any situation where we can spot a case-of-known-constructor + +As a result, the only time we should get residual coercion boxes in the code is +when the type checker generates something like: + + \eqv -> let eqv' = Eq# (case eqv of Eq# cov -> ... cov ...) + +However, the case of lambda-bound equality evidence is fairly rare, so these two +rules should suffice for solving the rule LHS problem for now. + +Annoyingly, we cannot use this modified rule 1a instead of 1: + + 1a. If we come across a let-bound constructor application with trivial arguments, + add an appropriate unfolding to the let binder. We spot constructor applications + by using exprIsConApp_maybe, so this would actually let rule 2a reduce more. + +The reason is that we REALLY NEED coercion boxes to be substituted away. With rule 1a +we wouldn't simplify this expression at all: + + let eqv = Eq# co + in foo eqv (bar eqv) + +The rule LHS desugarer can't deal with Let at all, so we need to push that box into +the use sites. +-} + +simpleOptExpr :: CoreExpr -> CoreExpr +-- 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 [Optimise coercion boxes agressively]. +-- +-- 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 expr + = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) + simpleOptExprWith 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 :: Subst -> InExpr -> OutExpr +simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr) + +---------------------- +simpleOptPgm :: DynFlags -> Module + -> CoreProgram -> [CoreRule] -> [CoreVect] + -> IO (CoreProgram, [CoreRule], [CoreVect]) +simpleOptPgm dflags this_mod binds rules vects + = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + (pprCoreBindings occ_anald_binds $$ pprRules rules ); + + ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) } + where + occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -} + rules vects emptyVarEnv binds + (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds + + do_one (subst, binds') bind + = case simple_opt_bind subst bind of + (subst', Nothing) -> (subst', binds') + (subst', Just bind') -> (subst', bind':binds') + +---------------------- +type InVar = Var +type OutVar = Var +type InId = Id +type OutId = Id +type InExpr = CoreExpr +type OutExpr = CoreExpr + +-- In these functions the substitution maps InVar -> OutExpr + +---------------------- +simple_opt_expr :: Subst -> InExpr -> OutExpr +simple_opt_expr subst expr + = go expr + where + in_scope_env = (substInScope subst, simpleUnfoldingFun) + + go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v + go (App e1 e2) = simple_app subst e1 [go e2] + go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (optCoercion (getCvSubst subst) co) + go (Lit lit) = Lit lit + go (Tick tickish e) = Tick (substTickish subst tickish) (go e) + go (Cast e co) | isReflCo co' = go e + | otherwise = Cast (go e) co' + where + co' = optCoercion (getCvSubst subst) co + + go (Let bind body) = case simple_opt_bind subst bind of + (subst', Nothing) -> simple_opt_expr subst' body + (subst', Just bind) -> Let bind (simple_opt_expr subst' body) + + go lam@(Lam {}) = go_lam [] subst lam + go (Case e b ty as) + -- See Note [Optimise coercion boxes agressively] + | isDeadBinder b + , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e' + , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as + = case altcon of + DEFAULT -> go rhs + _ -> mkLets (catMaybes mb_binds) $ simple_opt_expr subst' rhs + where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst + (zipEqual "simpleOptExpr" bs es) + + | otherwise + = Case e' b' (substTy subst ty) + (map (go_alt subst') as) + where + e' = go e + (subst', b') = subst_opt_bndr subst b + + ---------------------- + go_alt subst (con, bndrs, rhs) + = (con, bndrs', simple_opt_expr subst' rhs) + where + (subst', bndrs') = subst_opt_bndrs subst bndrs + + ---------------------- + -- go_lam tries eta reduction + go_lam bs' subst (Lam b e) + = go_lam (b':bs') subst' e + where + (subst', b') = subst_opt_bndr subst b + go_lam bs' subst e + | Just etad_e <- tryEtaReduce bs e' = etad_e + | otherwise = mkLams bs e' + where + bs = reverse bs' + e' = simple_opt_expr subst e + +---------------------- +-- simple_app collects arguments for beta reduction +simple_app :: Subst -> InExpr -> [OutExpr] -> CoreExpr +simple_app subst (App e1 e2) as + = simple_app subst e1 (simple_opt_expr subst e2 : as) +simple_app subst (Lam b e) (a:as) + = case maybe_substitute subst b a of + Just ext_subst -> simple_app ext_subst e as + Nothing -> Let (NonRec b2 a) (simple_app subst' e as) + where + (subst', b') = subst_opt_bndr subst b + b2 = add_info subst' b b' +simple_app subst (Var v) as + | isCompulsoryUnfolding (idUnfolding v) + -- See Note [Unfold compulsory unfoldings in LHSs] + = simple_app subst (unfoldingTemplate (idUnfolding v)) as +simple_app subst e as + = foldl App (simple_opt_expr subst e) as + +---------------------- +simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind) +simple_opt_bind s b -- Can add trace stuff here + = simple_opt_bind' s b + +simple_opt_bind' subst (Rec prs) + = (subst'', res_bind) + where + res_bind = Just (Rec (reverse rev_prs')) + (subst', bndrs') = subst_opt_bndrs subst (map fst prs) + (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs') + do_pr (subst, prs) ((b,r), b') + = case maybe_substitute subst b r2 of + Just subst' -> (subst', prs) + Nothing -> (subst, (b2,r2):prs) + where + b2 = add_info subst b b' + r2 = simple_opt_expr subst r + +simple_opt_bind' subst (NonRec b r) + = simple_opt_out_bind subst (b, simple_opt_expr subst r) + +---------------------- +simple_opt_out_bind :: Subst -> (InVar, OutExpr) -> (Subst, Maybe CoreBind) +simple_opt_out_bind subst (b, r') + | Just ext_subst <- maybe_substitute subst b r' + = (ext_subst, Nothing) + | otherwise + = (subst', Just (NonRec b2 r')) + where + (subst', b') = subst_opt_bndr subst b + b2 = add_info subst' b b' + +---------------------- +maybe_substitute :: Subst -> InVar -> OutExpr -> Maybe Subst + -- (maybe_substitute subst in_var out_rhs) + -- either extends subst with (in_var -> out_rhs) + -- or returns Nothing +maybe_substitute subst b r + | Type ty <- r -- let a::* = TYPE ty in + = ASSERT( isTyVar b ) + Just (extendTvSubst subst b ty) + + | Coercion co <- r + = ASSERT( isCoVar b ) + Just (extendCvSubst subst b co) + + | isId b -- let x = e in + , not (isCoVar b) -- See Note [Do not inline CoVars unconditionally] + -- in SimplUtils + , safe_to_inline (idOccInfo b) + , isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt] + , not (isStableUnfolding (idUnfolding b)) + , not (isExportedId b) + , not (isUnLiftedType (idType b)) || exprOkForSpeculation r + = Just (extendIdSubst subst b r) + + | otherwise + = Nothing + where + -- Unconditionally safe to inline + safe_to_inline :: OccInfo -> Bool + safe_to_inline (IAmALoopBreaker {}) = False + safe_to_inline IAmDead = True + safe_to_inline (OneOcc in_lam one_br _) = (not in_lam && one_br) || trivial + safe_to_inline NoOccInfo = trivial + + trivial | exprIsTrivial r = True + | (Var fun, args) <- collectArgs r + , Just dc <- isDataConWorkId_maybe fun + , dc `hasKey` eqBoxDataConKey || dc `hasKey` coercibleDataConKey + , all exprIsTrivial args = True -- See Note [Optimise coercion boxes agressively] + | otherwise = False + +---------------------- +subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar) +subst_opt_bndr subst bndr + | isTyVar bndr = substTyVarBndr subst bndr + | isCoVar bndr = substCoVarBndr subst bndr + | otherwise = subst_opt_id_bndr subst bndr + +subst_opt_id_bndr :: Subst -> InId -> (Subst, 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 CoreSubst.substIdBndr +-- carefully does not do) because simplOptExpr invalidates it + +subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id + = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id) + where + id1 = uniqAway in_scope old_id + id2 = setIdType id1 (substTy subst (idType old_id)) + new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding + -- and fragile OccInfo + new_in_scope = in_scope `extendInScopeSet` new_id + + -- Extend the substitution if the unique has changed, + -- or there's some useful occurrence information + -- See the notes with substTyVarBndr for the delSubstEnv + new_id_subst | new_id /= old_id + = extendVarEnv id_subst old_id (Var new_id) + | otherwise + = delVarEnv id_subst old_id + +---------------------- +subst_opt_bndrs :: Subst -> [InVar] -> (Subst, [OutVar]) +subst_opt_bndrs subst bndrs + = mapAccumL subst_opt_bndr subst bndrs + +---------------------- +add_info :: Subst -> InVar -> OutVar -> OutVar +add_info subst old_bndr new_bndr + | isTyVar old_bndr = new_bndr + | otherwise = maybeModifyIdInfo mb_new_info new_bndr + where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr) + +simpleUnfoldingFun :: IdUnfoldingFun +simpleUnfoldingFun id + | isAlwaysActive (idInlineActivation id) = idUnfolding id + | otherwise = noUnfolding + +{- +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 `map coerce = coerce` as a rule, the rule will only ever +match if we replace 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 Desugar + +************************************************************************ +* * + 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. + +Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core +they are represented as unpackCString# "abc"# by MkCore.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. +-} + +data ConCont = CC [CoreExpr] Coercion + -- Substitution already applied + +-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is +-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@, +-- where t1..tk are the *universally-qantified* type args of 'dc' +exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) +exprIsConApp_maybe (in_scope, id_unf) expr + = go (Left in_scope) expr (CC [] (mkReflCo Representational (exprType expr))) + where + go :: Either InScopeSet Subst + -> CoreExpr -> ConCont + -> Maybe (DataCon, [Type], [CoreExpr]) + go subst (Tick t expr) cont + | not (tickishIsCode t) = go subst expr cont + go subst (Cast expr co1) (CC [] co2) + = go subst expr (CC [] (subst_co subst co1 `mkTransCo` co2)) + go subst (App fun arg) (CC args co) + = go subst fun (CC (subst_arg subst arg : args) co) + go subst (Lam var body) (CC (arg:args) co) + | exprIsTrivial arg -- Don't duplicate stuff! + = go (extend subst var arg) body (CC args co) + go (Right sub) (Var v) cont + = go (Left (substInScope sub)) + (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) + cont + + go (Left in_scope) (Var fun) cont@(CC args co) + + | Just con <- isDataConWorkId_maybe fun + , count isValArg args == idArity fun + = dealWithCoercion co con args + + -- 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) + = dealWithCoercion co con (map (substExpr (text "exprIsConApp1") subst) dfun_args) + + -- 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') rhs cont + + | (fun `hasKey` unpackCStringIdKey) + || (fun `hasKey` unpackCStringUtf8IdKey) + , [Lit (MachStr str)] <- args + = dealWithStringLiteral fun str co + where + unfolding = id_unf fun + + go _ _ _ = Nothing + + ---------------------------- + -- Operations on the (Either InScopeSet CoreSubst) + -- The Left case is wildly dominant + subst_co (Left {}) co = co + subst_co (Right s) co = CoreSubst.substCo s co + + subst_arg (Left {}) e = e + subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e + + 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, MkCore.mkStringExprFS +-- turns those into [] automatically, but just in case something else in GHC +-- generates a string literal directly. +dealWithStringLiteral _ str co + | BS.null str + = dealWithCoercion co nilDataCon [Type charTy] + +dealWithStringLiteral fun str co + = let strFS = mkFastStringByteString str + + char = mkConApp charDataCon [mkCharLit (headFS strFS)] + charTail = fastStringToByteString (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 (MachStr charTail)) + + in dealWithCoercion co consDataCon [Type charTy, char, rest] + +dealWithCoercion :: Coercion -> DataCon -> [CoreExpr] + -> Maybe (DataCon, [Type], [CoreExpr]) +dealWithCoercion co dc dc_args + | isReflCo co + , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args + = Just (dc, stripTypeArgs univ_ty_args, rest_args) + + | Pair _from_ty to_ty <- coercionKind co + , 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't nothing wrong with it + + = -- Here we do the KPush reduction rule as described in the FC paper + -- 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.) + let + tc_arity = tyConArity to_tc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tyvars = dataConExTyVars dc + arg_tys = dataConRepArgTys dc + + non_univ_args = dropList dc_univ_tyvars dc_args + (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args + + -- Make the "theta" from Fig 3 of the paper + gammas = decomposeCo tc_arity co + theta_subst = liftCoSubstWith Representational + (dc_univ_tyvars ++ dc_ex_tyvars) + -- existentials are at role N + (gammas ++ map (mkReflCo Nominal) + (stripTypeArgs 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 (theta_subst arg_ty) + + dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, + 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 (stripTypeArgs $ takeList dc_univ_tyvars dc_args)) + , dump_doc ) + ASSERT2( all isTypeArg ex_args, dump_doc ) + ASSERT2( equalLength val_args arg_tys, dump_doc ) + Just (dc, to_tc_arg_tys, ex_args ++ new_val_args) + + | otherwise + = Nothing + +stripTypeArgs :: [CoreExpr] -> [Type] +stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args ) + [ty | Type ty <- args] + -- We really do want isTypeArg here, not isTyCoArg! + +{- +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 (inclding +type args) matches what the dfun is expecting. This may be *less* +than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn +-} + +exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal +-- Same deal as exprIsConApp_maybe, but much simpler +-- Nevertheless we do need to look through unfoldings for +-- Integer 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 Rules.match, and is required to make +"map coerce = coerce" match. +-} + +exprIsLambda_maybe :: InScopeEnv -> CoreExpr -> Maybe (Var, CoreExpr) + -- See Note [exprIsLambda_maybe] + +-- The simple case: It is a lambda already +exprIsLambda_maybe _ (Lam x e) + = Just (x, e) + +-- Also possible: A casted lambda. Push the coercion inside +exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) + | Just (x, e) <- 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 + , let res = pushCoercionIntoLambda in_scope_set x e co + = -- 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) <- collectArgs e + , idArity f > length (filter 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 (mkEmptySubst in_scope_set) (rhs `mkApps` as) + -- Recurse, because of possible casts + , Just (x', e'') <- exprIsLambda_maybe (in_scope_set, id_unf) e' + , let res = Just (x', e'') + = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr res]) + res + +exprIsLambda_maybe _ _e + = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) + Nothing + + +pushCoercionIntoLambda + :: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr) +pushCoercionIntoLambda in_scope x e co + -- This implements the Push rule from the paper on coercions + -- Compare with simplCast in Simplify + | 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] = decomposeCo 2 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', subst_expr subst e `mkCast` co2) + | otherwise + = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) + Nothing diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs deleted file mode 100644 index 76f42f4bb9..0000000000 --- a/compiler/coreSyn/CoreSubst.lhs +++ /dev/null @@ -1,1422 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -Utility functions on @Core@ syntax - -\begin{code} -{-# LANGUAGE CPP #-} -module CoreSubst ( - -- * 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, lookupTvSubst, lookupCvSubst, substIdOcc, - substTickish, substVarSet, - - -- ** Operations on substitutions - emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, - extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList, - extendCvSubst, extendCvSubstList, - extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, - addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, - isInScope, setInScope, - delBndr, delBndrs, - - -- ** Substituting and cloning binders - substBndr, substBndrs, substRecBndrs, - cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, - - -- ** Simple expression optimiser - simpleOptPgm, simpleOptExpr, simpleOptExprWith, - exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, - ) where - -#include "HsVersions.h" - -import CoreSyn -import CoreFVs -import CoreUtils -import Literal ( Literal(MachStr) ) -import qualified Data.ByteString as BS -import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) - -import qualified Type -import qualified Coercion - - -- We are defining local versions -import Type hiding ( substTy, extendTvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr ) - -import TyCon ( tyConArity ) -import DataCon -import PrelNames ( eqBoxDataConKey, coercibleDataConKey, unpackCStringIdKey - , unpackCStringUtf8IdKey ) -import OptCoercion ( optCoercion ) -import PprCore ( pprCoreBindings, pprRules ) -import Module ( Module ) -import VarSet -import VarEnv -import Id -import Name ( Name ) -import Var -import IdInfo -import Unique -import UniqSupply -import Maybes -import ErrUtils -import DynFlags -import BasicTypes ( isAlwaysActive ) -import Util -import Pair -import Outputable -import PprCore () -- Instances -import FastString - -import Data.List - -import TysWiredIn -\end{code} - - -%************************************************************************ -%* * -\subsection{Substitutions} -%* * -%************************************************************************ - -\begin{code} --- | A substitution environment, containing both 'Id' and 'TyVar' substitutions. --- --- Some invariants apply to how you use the substitution: --- --- 1. #in_scope_invariant# The in-scope set contains at least those 'Id's and 'TyVar's that will be in scope /after/ --- applying the substitution to a term. Precisely, the in-scope set must be a superset of the free vars of the --- substitution range that might possibly clash with locally-bound variables in the thing being substituted in. --- --- 2. #apply_once# You may apply the substitution only /once/ --- --- There are various ways of setting up the in-scope set such that the first of these invariants hold: --- --- * Arrange that the in-scope set really is all the things in scope --- --- * Arrange that it's the free vars of the range of the substitution --- --- * Make it empty, if you know that all the free vars of the substitution are fresh, and hence can't possibly clash -data Subst - = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ - -- applying the substitution - IdSubstEnv -- Substitution for Ids - TvSubstEnv -- Substitution from TyVars to Types - CvSubstEnv -- Substitution from CoVars to Coercions - - -- INVARIANT 1: See #in_scope_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] -\end{code} - -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 TvSubst] with Type.TvSubstEnv - -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 the TvSubstEnv and IdSubstEnv are both 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 - -\begin{code} --- | An environment for substituting for 'Id's -type IdSubstEnv = IdEnv CoreExpr - ----------------------------- -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 "CoreSubst#in_scope_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 the "CoreSubst#in_scope_invariant" is true 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 = 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 = Subst in_scope (extendVarEnvList ids prs) tvs cvs - --- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is --- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this -extendTvSubst :: Subst -> TyVar -> Type -> Subst -extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEnv tvs v r) cvs - --- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' -extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst -extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs - --- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is --- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this -extendCvSubst :: Subst -> CoVar -> Coercion -> Subst -extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r) - --- | Adds multiple 'CoVar' -> 'Coercion' substitutions to the --- 'Subst': see also 'extendCvSubst' -extendCvSubstList :: Subst -> [(CoVar,Coercion)] -> Subst -extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs) - --- | Add a substitution appropriate to the thing being substituted --- (whether an expression, type, or coercion). See also --- 'extendIdSubst', 'extendTvSubst', and '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, ptext (sLit "CoreSubst.lookupIdSubst") <+> doc <+> ppr v - $$ ppr in_scope) - Var v - --- | Find the substitution for a 'TyVar' in the 'Subst' -lookupTvSubst :: Subst -> TyVar -> Type -lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v - --- | Find the coercion substitution for a 'CoVar' in the 'Subst' -lookupCvSubst :: Subst -> CoVar -> Coercion -lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) 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 -\end{code} - -Pretty printing, for debugging only - -\begin{code} -instance Outputable Subst where - ppr (Subst in_scope ids tvs cvs) - = ptext (sLit " braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope)))) - $$ ptext (sLit " IdSubst =") <+> ppr ids - $$ ptext (sLit " TvSubst =") <+> ppr tvs - $$ ptext (sLit " CvSubst =") <+> ppr cvs - <> char '>' -\end{code} - - -%************************************************************************ -%* * - Substituting expressions -%* * -%************************************************************************ - -\begin{code} --- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only --- apply the substitution /once/: see "CoreSubst#apply_once" --- --- 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 subst orig_expr - -substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr -substExpr _doc subst orig_expr = subst_expr subst orig_expr - -subst_expr :: Subst -> CoreExpr -> CoreExpr -subst_expr subst expr - = go expr - where - go (Var v) = lookupIdSubst (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) = Tick (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 subst' body) - where - (subst', bndr') = substBndr subst bndr - - go (Let bind body) = Let bind' (subst_expr 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 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 subst') rhss - -substBind subst (NonRec bndr rhs) = (subst', NonRec bndr' (subst_expr 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 subst') rhss -\end{code} - -\begin{code} --- | 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) -\end{code} - - -%************************************************************************ -%* * - 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. - -\begin{code} --- | 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 -\end{code} - - -\begin{code} -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 || - isEmptyVarSet (Type.tyVarsOfType 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 -\end{code} - -Now a variant that unconditionally allocates a new unique. -It also unconditionally zaps the OccInfo. - -\begin{code} --- | 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) -\end{code} - - -%************************************************************************ -%* * - 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 TvSubst. - -\begin{code} -substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) -substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv - = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of - (TvSubst in_scope' tv_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 (TvSubst in_scope tv_env) tv uniq of - (TvSubst in_scope' tv_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 (CvSubst in_scope tv_env cv_env) cv of - (CvSubst 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.substTy (getTvSubst subst) ty - -getTvSubst :: Subst -> TvSubst -getTvSubst (Subst in_scope _ tenv _) = TvSubst in_scope tenv - -getCvSubst :: Subst -> CvSubst -getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv - --- | See 'Coercion.substCo' -substCo :: Subst -> Coercion -> Coercion -substCo subst co = Coercion.substCo (getCvSubst subst) co -\end{code} - - -%************************************************************************ -%* * -\section{IdInfo substitution} -%* * -%************************************************************************ - -\begin{code} -substIdType :: Subst -> Id -> Id -substIdType subst@(Subst _ _ tv_env cv_env) id - | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id - | otherwise = setIdType id (substTy subst old_ty) - -- The tyVarsOfType 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 `setSpecInfo` substSpec subst new_id old_rules - `setUnfoldingInfo` substUnfolding subst old_unf) - where - old_rules = specInfo info - old_unf = unfoldingInfo info - nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding 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 -> SpecInfo -> SpecInfo -substSpec subst new_id (SpecInfo rules rhs_fvs) - = seqSpecInfo new_spec `seq` new_spec - where - subst_ru_fn = const (idName new_id) - new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules) - (substVarSet 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 (text "subst-rule" <+> ppr fn_name) subst') args, - ru_rhs = simpleOptExprWith subst' rhs } - -- Do simple optimisation on RHS, in case substitution lets - -- you improve it. The real simplifier never gets to look at it. - where - (subst', bndrs') = substBndrs subst bndrs - ------------------- -substVects :: Subst -> [CoreVect] -> [CoreVect] -substVects subst = map (substVect subst) - ------------------- -substVect :: Subst -> CoreVect -> CoreVect -substVect subst (Vect v rhs) = Vect v (simpleOptExprWith subst rhs) -substVect _subst vd@(NoVect _) = vd -substVect _subst vd@(VectType _ _ _) = vd -substVect _subst vd@(VectClass _) = vd -substVect _subst vd@(VectInst _) = vd - ------------------- -substVarSet :: Subst -> VarSet -> VarSet -substVarSet subst fvs - = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs - where - subst_fv subst fv - | isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv) - | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv) - ------------------- -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 [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 Coverage.mkTickish. -Breakpoints can't handle free variables with unlifted types anyway. --} -\end{code} - -Note [Worker inlining] -~~~~~~~~~~~~~~~~~~~~~~ -A worker can get sustituted 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. - - -%************************************************************************ -%* * - The Very Simple Optimiser -%* * -%************************************************************************ - -Note [Optimise coercion boxes agressively] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The simple expression optimiser needs to deal with Eq# boxes as follows: - 1. If the result of optimising the RHS of a non-recursive binding is an - Eq# box, that box is substituted rather than turned into a let, just as - if it were trivial. - let eqv = Eq# co in e ==> e[Eq# co/eqv] - - 2. If the result of optimising a case scrutinee is a Eq# box and the case - deconstructs it in a trivial way, we evaluate the case then and there. - case Eq# co of Eq# cov -> e ==> e[co/cov] - -We do this for two reasons: - - 1. Bindings/case scrutinisation of this form is often created by the - evidence-binding mechanism and we need them to be inlined to be able - desugar RULE LHSes that involve equalities (see e.g. T2291) - - 2. The test T4356 fails Lint because it creates a coercion between types - of kind (* -> * -> *) and (?? -> ? -> *), which differ. If we do this - inlining agressively we can collapse away the intermediate coercion between - these two types and hence pass Lint again. (This is a sort of a hack.) - -In fact, our implementation uses slightly liberalised versions of the second rule -rule so that the optimisations are a bit more generally applicable. Precisely: - 2a. We reduce any situation where we can spot a case-of-known-constructor - -As a result, the only time we should get residual coercion boxes in the code is -when the type checker generates something like: - - \eqv -> let eqv' = Eq# (case eqv of Eq# cov -> ... cov ...) - -However, the case of lambda-bound equality evidence is fairly rare, so these two -rules should suffice for solving the rule LHS problem for now. - -Annoyingly, we cannot use this modified rule 1a instead of 1: - - 1a. If we come across a let-bound constructor application with trivial arguments, - add an appropriate unfolding to the let binder. We spot constructor applications - by using exprIsConApp_maybe, so this would actually let rule 2a reduce more. - -The reason is that we REALLY NEED coercion boxes to be substituted away. With rule 1a -we wouldn't simplify this expression at all: - - let eqv = Eq# co - in foo eqv (bar eqv) - -The rule LHS desugarer can't deal with Let at all, so we need to push that box into -the use sites. - -\begin{code} -simpleOptExpr :: CoreExpr -> CoreExpr --- 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 [Optimise coercion boxes agressively]. --- --- 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 expr - = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) - simpleOptExprWith 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 :: Subst -> InExpr -> OutExpr -simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr) - ----------------------- -simpleOptPgm :: DynFlags -> Module - -> CoreProgram -> [CoreRule] -> [CoreVect] - -> IO (CoreProgram, [CoreRule], [CoreVect]) -simpleOptPgm dflags this_mod binds rules vects - = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" - (pprCoreBindings occ_anald_binds $$ pprRules rules ); - - ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) } - where - occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -} - rules vects emptyVarEnv binds - (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds - - do_one (subst, binds') bind - = case simple_opt_bind subst bind of - (subst', Nothing) -> (subst', binds') - (subst', Just bind') -> (subst', bind':binds') - ----------------------- -type InVar = Var -type OutVar = Var -type InId = Id -type OutId = Id -type InExpr = CoreExpr -type OutExpr = CoreExpr - --- In these functions the substitution maps InVar -> OutExpr - ----------------------- -simple_opt_expr :: Subst -> InExpr -> OutExpr -simple_opt_expr subst expr - = go expr - where - in_scope_env = (substInScope subst, simpleUnfoldingFun) - - go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v - go (App e1 e2) = simple_app subst e1 [go e2] - go (Type ty) = Type (substTy subst ty) - go (Coercion co) = Coercion (optCoercion (getCvSubst subst) co) - go (Lit lit) = Lit lit - go (Tick tickish e) = Tick (substTickish subst tickish) (go e) - go (Cast e co) | isReflCo co' = go e - | otherwise = Cast (go e) co' - where - co' = optCoercion (getCvSubst subst) co - - go (Let bind body) = case simple_opt_bind subst bind of - (subst', Nothing) -> simple_opt_expr subst' body - (subst', Just bind) -> Let bind (simple_opt_expr subst' body) - - go lam@(Lam {}) = go_lam [] subst lam - go (Case e b ty as) - -- See Note [Optimise coercion boxes agressively] - | isDeadBinder b - , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e' - , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as - = case altcon of - DEFAULT -> go rhs - _ -> mkLets (catMaybes mb_binds) $ simple_opt_expr subst' rhs - where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst - (zipEqual "simpleOptExpr" bs es) - - | otherwise - = Case e' b' (substTy subst ty) - (map (go_alt subst') as) - where - e' = go e - (subst', b') = subst_opt_bndr subst b - - ---------------------- - go_alt subst (con, bndrs, rhs) - = (con, bndrs', simple_opt_expr subst' rhs) - where - (subst', bndrs') = subst_opt_bndrs subst bndrs - - ---------------------- - -- go_lam tries eta reduction - go_lam bs' subst (Lam b e) - = go_lam (b':bs') subst' e - where - (subst', b') = subst_opt_bndr subst b - go_lam bs' subst e - | Just etad_e <- tryEtaReduce bs e' = etad_e - | otherwise = mkLams bs e' - where - bs = reverse bs' - e' = simple_opt_expr subst e - ----------------------- --- simple_app collects arguments for beta reduction -simple_app :: Subst -> InExpr -> [OutExpr] -> CoreExpr -simple_app subst (App e1 e2) as - = simple_app subst e1 (simple_opt_expr subst e2 : as) -simple_app subst (Lam b e) (a:as) - = case maybe_substitute subst b a of - Just ext_subst -> simple_app ext_subst e as - Nothing -> Let (NonRec b2 a) (simple_app subst' e as) - where - (subst', b') = subst_opt_bndr subst b - b2 = add_info subst' b b' -simple_app subst (Var v) as - | isCompulsoryUnfolding (idUnfolding v) - -- See Note [Unfold compulsory unfoldings in LHSs] - = simple_app subst (unfoldingTemplate (idUnfolding v)) as -simple_app subst e as - = foldl App (simple_opt_expr subst e) as - ----------------------- -simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind) -simple_opt_bind s b -- Can add trace stuff here - = simple_opt_bind' s b - -simple_opt_bind' subst (Rec prs) - = (subst'', res_bind) - where - res_bind = Just (Rec (reverse rev_prs')) - (subst', bndrs') = subst_opt_bndrs subst (map fst prs) - (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs') - do_pr (subst, prs) ((b,r), b') - = case maybe_substitute subst b r2 of - Just subst' -> (subst', prs) - Nothing -> (subst, (b2,r2):prs) - where - b2 = add_info subst b b' - r2 = simple_opt_expr subst r - -simple_opt_bind' subst (NonRec b r) - = simple_opt_out_bind subst (b, simple_opt_expr subst r) - ----------------------- -simple_opt_out_bind :: Subst -> (InVar, OutExpr) -> (Subst, Maybe CoreBind) -simple_opt_out_bind subst (b, r') - | Just ext_subst <- maybe_substitute subst b r' - = (ext_subst, Nothing) - | otherwise - = (subst', Just (NonRec b2 r')) - where - (subst', b') = subst_opt_bndr subst b - b2 = add_info subst' b b' - ----------------------- -maybe_substitute :: Subst -> InVar -> OutExpr -> Maybe Subst - -- (maybe_substitute subst in_var out_rhs) - -- either extends subst with (in_var -> out_rhs) - -- or returns Nothing -maybe_substitute subst b r - | Type ty <- r -- let a::* = TYPE ty in - = ASSERT( isTyVar b ) - Just (extendTvSubst subst b ty) - - | Coercion co <- r - = ASSERT( isCoVar b ) - Just (extendCvSubst subst b co) - - | isId b -- let x = e in - , not (isCoVar b) -- See Note [Do not inline CoVars unconditionally] - -- in SimplUtils - , safe_to_inline (idOccInfo b) - , isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt] - , not (isStableUnfolding (idUnfolding b)) - , not (isExportedId b) - , not (isUnLiftedType (idType b)) || exprOkForSpeculation r - = Just (extendIdSubst subst b r) - - | otherwise - = Nothing - where - -- Unconditionally safe to inline - safe_to_inline :: OccInfo -> Bool - safe_to_inline (IAmALoopBreaker {}) = False - safe_to_inline IAmDead = True - safe_to_inline (OneOcc in_lam one_br _) = (not in_lam && one_br) || trivial - safe_to_inline NoOccInfo = trivial - - trivial | exprIsTrivial r = True - | (Var fun, args) <- collectArgs r - , Just dc <- isDataConWorkId_maybe fun - , dc `hasKey` eqBoxDataConKey || dc `hasKey` coercibleDataConKey - , all exprIsTrivial args = True -- See Note [Optimise coercion boxes agressively] - | otherwise = False - ----------------------- -subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar) -subst_opt_bndr subst bndr - | isTyVar bndr = substTyVarBndr subst bndr - | isCoVar bndr = substCoVarBndr subst bndr - | otherwise = subst_opt_id_bndr subst bndr - -subst_opt_id_bndr :: Subst -> InId -> (Subst, 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 CoreSubst.substIdBndr --- carefully does not do) because simplOptExpr invalidates it - -subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id - = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id) - where - id1 = uniqAway in_scope old_id - id2 = setIdType id1 (substTy subst (idType old_id)) - new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding - -- and fragile OccInfo - new_in_scope = in_scope `extendInScopeSet` new_id - - -- Extend the substitution if the unique has changed, - -- or there's some useful occurrence information - -- See the notes with substTyVarBndr for the delSubstEnv - new_id_subst | new_id /= old_id - = extendVarEnv id_subst old_id (Var new_id) - | otherwise - = delVarEnv id_subst old_id - ----------------------- -subst_opt_bndrs :: Subst -> [InVar] -> (Subst, [OutVar]) -subst_opt_bndrs subst bndrs - = mapAccumL subst_opt_bndr subst bndrs - ----------------------- -add_info :: Subst -> InVar -> OutVar -> OutVar -add_info subst old_bndr new_bndr - | isTyVar old_bndr = new_bndr - | otherwise = maybeModifyIdInfo mb_new_info new_bndr - where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr) - -simpleUnfoldingFun :: IdUnfoldingFun -simpleUnfoldingFun id - | isAlwaysActive (idInlineActivation id) = idUnfolding id - | otherwise = noUnfolding -\end{code} - -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 `map coerce = coerce` as a rule, the rule will only ever -match if we replace 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 Desugar - -%************************************************************************ -%* * - 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. - -Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core -they are represented as unpackCString# "abc"# by MkCore.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. - -\begin{code} -data ConCont = CC [CoreExpr] Coercion - -- Substitution already applied - --- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is --- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@, --- where t1..tk are the *universally-qantified* type args of 'dc' -exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) -exprIsConApp_maybe (in_scope, id_unf) expr - = go (Left in_scope) expr (CC [] (mkReflCo Representational (exprType expr))) - where - go :: Either InScopeSet Subst - -> CoreExpr -> ConCont - -> Maybe (DataCon, [Type], [CoreExpr]) - go subst (Tick t expr) cont - | not (tickishIsCode t) = go subst expr cont - go subst (Cast expr co1) (CC [] co2) - = go subst expr (CC [] (subst_co subst co1 `mkTransCo` co2)) - go subst (App fun arg) (CC args co) - = go subst fun (CC (subst_arg subst arg : args) co) - go subst (Lam var body) (CC (arg:args) co) - | exprIsTrivial arg -- Don't duplicate stuff! - = go (extend subst var arg) body (CC args co) - go (Right sub) (Var v) cont - = go (Left (substInScope sub)) - (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) - cont - - go (Left in_scope) (Var fun) cont@(CC args co) - - | Just con <- isDataConWorkId_maybe fun - , count isValArg args == idArity fun - = dealWithCoercion co con args - - -- 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) - = dealWithCoercion co con (map (substExpr (text "exprIsConApp1") subst) dfun_args) - - -- 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') rhs cont - - | (fun `hasKey` unpackCStringIdKey) - || (fun `hasKey` unpackCStringUtf8IdKey) - , [Lit (MachStr str)] <- args - = dealWithStringLiteral fun str co - where - unfolding = id_unf fun - - go _ _ _ = Nothing - - ---------------------------- - -- Operations on the (Either InScopeSet CoreSubst) - -- The Left case is wildly dominant - subst_co (Left {}) co = co - subst_co (Right s) co = CoreSubst.substCo s co - - subst_arg (Left {}) e = e - subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e - - 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, MkCore.mkStringExprFS --- turns those into [] automatically, but just in case something else in GHC --- generates a string literal directly. -dealWithStringLiteral _ str co - | BS.null str - = dealWithCoercion co nilDataCon [Type charTy] - -dealWithStringLiteral fun str co - = let strFS = mkFastStringByteString str - - char = mkConApp charDataCon [mkCharLit (headFS strFS)] - charTail = fastStringToByteString (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 (MachStr charTail)) - - in dealWithCoercion co consDataCon [Type charTy, char, rest] - -dealWithCoercion :: Coercion -> DataCon -> [CoreExpr] - -> Maybe (DataCon, [Type], [CoreExpr]) -dealWithCoercion co dc dc_args - | isReflCo co - , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args - = Just (dc, stripTypeArgs univ_ty_args, rest_args) - - | Pair _from_ty to_ty <- coercionKind co - , 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't nothing wrong with it - - = -- Here we do the KPush reduction rule as described in the FC paper - -- 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.) - let - tc_arity = tyConArity to_tc - dc_univ_tyvars = dataConUnivTyVars dc - dc_ex_tyvars = dataConExTyVars dc - arg_tys = dataConRepArgTys dc - - non_univ_args = dropList dc_univ_tyvars dc_args - (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args - - -- Make the "theta" from Fig 3 of the paper - gammas = decomposeCo tc_arity co - theta_subst = liftCoSubstWith Representational - (dc_univ_tyvars ++ dc_ex_tyvars) - -- existentials are at role N - (gammas ++ map (mkReflCo Nominal) - (stripTypeArgs 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 (theta_subst arg_ty) - - dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, - 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 (stripTypeArgs $ takeList dc_univ_tyvars dc_args)) - , dump_doc ) - ASSERT2( all isTypeArg ex_args, dump_doc ) - ASSERT2( equalLength val_args arg_tys, dump_doc ) - Just (dc, to_tc_arg_tys, ex_args ++ new_val_args) - - | otherwise - = Nothing - -stripTypeArgs :: [CoreExpr] -> [Type] -stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args ) - [ty | Type ty <- args] - -- We really do want isTypeArg here, not isTyCoArg! -\end{code} - -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 (inclding -type args) matches what the dfun is expecting. This may be *less* -than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn - -\begin{code} -exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal --- Same deal as exprIsConApp_maybe, but much simpler --- Nevertheless we do need to look through unfoldings for --- Integer 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 -\end{code} - -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 Rules.match, and is required to make -"map coerce = coerce" match. - -\begin{code} -exprIsLambda_maybe :: InScopeEnv -> CoreExpr -> Maybe (Var, CoreExpr) - -- See Note [exprIsLambda_maybe] - --- The simple case: It is a lambda already -exprIsLambda_maybe _ (Lam x e) - = Just (x, e) - --- Also possible: A casted lambda. Push the coercion inside -exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) - | Just (x, e) <- 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 - , let res = pushCoercionIntoLambda in_scope_set x e co - = -- 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) <- collectArgs e - , idArity f > length (filter 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 (mkEmptySubst in_scope_set) (rhs `mkApps` as) - -- Recurse, because of possible casts - , Just (x', e'') <- exprIsLambda_maybe (in_scope_set, id_unf) e' - , let res = Just (x', e'') - = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr res]) - res - -exprIsLambda_maybe _ _e - = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) - Nothing - - -pushCoercionIntoLambda - :: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr) -pushCoercionIntoLambda in_scope x e co - -- This implements the Push rule from the paper on coercions - -- Compare with simplCast in Simplify - | 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] = decomposeCo 2 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', subst_expr subst e `mkCast` co2) - | otherwise - = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) - Nothing - -\end{code} diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs new file mode 100644 index 0000000000..0c6ee7c38e --- /dev/null +++ b/compiler/coreSyn/CoreSyn.hs @@ -0,0 +1,1502 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} + +-- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection +module CoreSyn ( + -- * Main data types + Expr(..), Alt, Bind(..), AltCon(..), Arg, Tickish(..), + CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, + TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, + + -- ** 'Expr' construction + mkLets, mkLams, + mkApps, mkTyApps, mkCoApps, mkVarApps, + + mkIntLit, mkIntLitInt, + mkWordLit, mkWordLitWord, + mkWord64LitWord64, mkInt64LitInt64, + mkCharLit, mkStringLit, + mkFloatLit, mkFloatLitFloat, + mkDoubleLit, mkDoubleLitDouble, + + mkConApp, mkConApp2, mkTyBind, mkCoBind, + varToCoreExpr, varsToCoreExprs, + + isId, cmpAltCon, cmpAlt, ltAlt, + + -- ** Simple 'Expr' access functions and predicates + bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, + collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, + collectArgs, flattenBinds, + + isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount, + isRuntimeArg, isRuntimeVar, + + tickishCounts, tickishScoped, tickishIsCode, mkNoCount, mkNoScope, + tickishCanSplit, + + -- * Unfolding data types + Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), + + -- ** Constructing 'Unfolding's + noUnfolding, evaldUnfolding, mkOtherCon, + unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, + + -- ** Predicates and deconstruction on 'Unfolding' + unfoldingTemplate, expandUnfolding_maybe, + maybeUnfoldingTemplate, otherCons, + isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, + isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, + isStableUnfolding, hasStableCoreUnfolding_maybe, + isClosedUnfolding, hasSomeUnfolding, + canUnfold, neverUnfoldGuidance, isStableSource, + + -- * Strictness + seqExpr, seqExprs, seqUnfolding, + + -- * Annotated expression data types + AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, + + -- ** Operations on annotated expressions + collectAnnArgs, + + -- ** Operations on annotations + deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs, + + -- * Core rule data types + CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only + RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, + + -- ** Operations on 'CoreRule's + seqRules, ruleArity, ruleName, ruleIdName, ruleActivation, + setRuleIdName, + isBuiltinRule, isLocalRule, isAutoRule, + + -- * Core vectorisation declarations data type + CoreVect(..) + ) where + +#include "HsVersions.h" + +import CostCentre +import VarEnv( InScopeSet ) +import Var +import Type +import Coercion +import Name +import Literal +import DataCon +import Module +import TyCon +import BasicTypes +import DynFlags +import FastString +import Outputable +import Util + +import Data.Data hiding (TyCon) +import Data.Int +import Data.Word + +infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` +-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) + +{- +************************************************************************ +* * +\subsection{The main data types} +* * +************************************************************************ + +These data types are the heart of the compiler +-} + +-- | This is the data type that represents GHCs core intermediate language. Currently +-- GHC uses System FC for this purpose, +-- which is closely related to the simpler and better known System F . +-- +-- We get from Haskell source to this Core language in a number of stages: +-- +-- 1. The source code is parsed into an abstract syntax tree, which is represented +-- by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames' +-- +-- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName' +-- (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical. +-- For example, this program: +-- +-- @ +-- f x = let f x = x + 1 +-- in f (x - 2) +-- @ +-- +-- Would be renamed by having 'Unique's attached so it looked something like this: +-- +-- @ +-- f_1 x_2 = let f_3 x_4 = x_4 + 1 +-- in f_3 (x_2 - 2) +-- @ +-- But see Note [Shadowing] below. +-- +-- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating +-- type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names. +-- +-- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into +-- this 'Expr' type, which has far fewer constructors and hence is easier to perform +-- optimization, analysis and code generation on. +-- +-- The type parameter @b@ is for the type of binders in the expression tree. +-- +-- The language consists of the following elements: +-- +-- * Variables +-- +-- * Primitive literals +-- +-- * Applications: note that the argument may be a 'Type'. +-- +-- See "CoreSyn#let_app_invariant" for another invariant +-- +-- * Lambda abstraction +-- +-- * Recursive and non recursive @let@s. Operationally +-- this corresponds to allocating a thunk for the things +-- bound and then executing the sub-expression. +-- +-- #top_level_invariant# +-- #letrec_invariant# +-- +-- The right hand sides of all top-level and recursive @let@s +-- /must/ be of lifted type (see "Type#type_classification" for +-- the meaning of /lifted/ vs. /unlifted/). +-- +-- See Note [CoreSyn let/app invariant] +-- +-- #type_let# +-- We allow a /non-recursive/ let to bind a type variable, thus: +-- +-- > Let (NonRec tv (Type ty)) body +-- +-- This can be very convenient for postponing type substitutions until +-- the next run of the simplifier. +-- +-- At the moment, the rest of the compiler only deals with type-let +-- in a Let expression, rather than at top level. We may want to revist +-- this choice. +-- +-- * Case split. Operationally this corresponds to evaluating +-- the scrutinee (expression examined) to weak head normal form +-- and then examining at most one level of resulting constructor (i.e. you +-- cannot do nested pattern matching directly with this). +-- +-- The binder gets bound to the value of the scrutinee, +-- and the 'Type' must be that of all the case alternatives +-- +-- #case_invariants# +-- This is one of the more complicated elements of the Core language, +-- and comes with a number of restrictions: +-- +-- 1. The list of alternatives may be empty; +-- See Note [Empty case alternatives] +-- +-- 2. The 'DEFAULT' case alternative must be first in the list, +-- if it occurs at all. +-- +-- 3. The remaining cases are in order of increasing +-- tag (for 'DataAlts') or +-- lit (for 'LitAlts'). +-- This makes finding the relevant constructor easy, +-- and makes comparison easier too. +-- +-- 4. The list of alternatives must be exhaustive. An /exhaustive/ case +-- does not necessarily mention all constructors: +-- +-- @ +-- data Foo = Red | Green | Blue +-- ... case x of +-- Red -> True +-- other -> f (case x of +-- Green -> ... +-- Blue -> ... ) ... +-- @ +-- +-- The inner case does not need a @Red@ alternative, because @x@ +-- can't be @Red@ at that program point. +-- +-- * Cast an expression to a particular type. +-- This is used to implement @newtype@s (a @newtype@ constructor or +-- destructor just becomes a 'Cast' in Core) and GADTs. +-- +-- * Notes. These allow general information to be added to expressions +-- in the syntax tree +-- +-- * A type: this should only show up at the top level of an Arg +-- +-- * A coercion + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data Expr b + = Var Id + | Lit Literal + | App (Expr b) (Arg b) + | Lam b (Expr b) + | Let (Bind b) (Expr b) + | Case (Expr b) b Type [Alt b] -- See #case_invariant# + | Cast (Expr b) Coercion + | Tick (Tickish Id) (Expr b) + | Type Type + | Coercion Coercion + deriving (Data, Typeable) + +-- | Type synonym for expressions that occur in function argument positions. +-- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not +type Arg b = Expr b + +-- | A case split alternative. Consists of the constructor leading to the alternative, +-- the variables bound from the constructor, and the expression to be executed given that binding. +-- The default alternative is @(DEFAULT, [], rhs)@ + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +type Alt b = (AltCon, [b], Expr b) + +-- | A case alternative constructor (i.e. pattern match) + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data AltCon + = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@. + -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@ + + | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@ + -- Invariant: always an *unlifted* literal + -- See Note [Literal alternatives] + + | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@ + deriving (Eq, Ord, Data, Typeable) + +-- | Binding, used for top level bindings in a module and local bindings in a @let@. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data Bind b = NonRec b (Expr b) + | Rec [(b, (Expr b))] + deriving (Data, Typeable) + +{- +Note [Shadowing] +~~~~~~~~~~~~~~~~ +While various passes attempt to rename on-the-fly in a manner that +avoids "shadowing" (thereby simplifying downstream optimizations), +neither the simplifier nor any other pass GUARANTEES that shadowing is +avoided. Thus, all passes SHOULD work fine even in the presence of +arbitrary shadowing in their inputs. + +In particular, scrutinee variables `x` in expressions of the form +`Case e x t` are often renamed to variables with a prefix +"wild_". These "wild" variables may appear in the body of the +case-expression, and further, may be shadowed within the body. + +So the Unique in an Var is not really unique at all. Still, it's very +useful to give a constant-time equality/ordering for Vars, and to give +a key that can be used to make sets of Vars (VarSet), or mappings from +Vars to other things (VarEnv). Moreover, if you do want to eliminate +shadowing, you can give a new Unique to an Id without changing its +printable name, which makes debugging easier. + +Note [Literal alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Literal alternatives (LitAlt lit) are always for *un-lifted* literals. +We have one literal, a literal Integer, that is lifted, and we don't +allow in a LitAlt, because LitAlt cases don't do any evaluation. Also +(see Trac #5603) if you say + case 3 of + S# x -> ... + J# _ _ -> ... +(where S#, J# are the constructors for Integer) we don't want the +simplifier calling findAlt with argument (LitAlt 3). No no. Integer +literals are an opaque encoding of an algebraic data type, not of +an unlifted literal, like all the others. + + +-------------------------- CoreSyn INVARIANTS --------------------------- + +Note [CoreSyn top-level invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #toplevel_invariant# + +Note [CoreSyn letrec invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #letrec_invariant# + +Note [CoreSyn let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The let/app invariant + the right hand side of of a non-recursive 'Let', and + the argument of an 'App', + /may/ be of unlifted type, but only if + the expression is ok-for-speculation. + +This means that the let can be floated around +without difficulty. For example, this is OK: + + y::Int# = x +# 1# + +But this is not, as it may affect termination if the +expression is floated out: + + y::Int# = fac 4# + +In this situation you should use @case@ rather than a @let@. The function +'CoreUtils.needsCaseBinding' can help you determine which to generate, or +alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, +which will generate a @case@ if necessary + +Th let/app invariant is initially enforced by DsUtils.mkCoreLet and mkCoreApp + +Note [CoreSyn case invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #case_invariants# + +Note [CoreSyn let goal] +~~~~~~~~~~~~~~~~~~~~~~~ +* The simplifier tries to ensure that if the RHS of a let is a constructor + application, its arguments are trivial, so that the constructor can be + inlined vigorously. + +Note [Type let] +~~~~~~~~~~~~~~~ +See #type_let# + +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The alternatives of a case expression should be exhaustive. A case expression +can have empty alternatives if (and only if) the scrutinee is bound to raise +an exception or diverge. So: + Case (error Int "Hello") b Bool [] +is fine, and has type Bool. This is one reason we need a type on +the case expression: if the alternatives are empty we can't get the type +from the alternatives! I'll write this + case (error Int "Hello") of Bool {} +with the return type just before the alternatives. + +Here's another 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. Its a bit of a +degnerate situation but we do NOT want to replace + case x of Bool {} --> error Bool "Inaccessible case" +because x might raise an exception, and *that*'s what we want to see! +(Trac #6067 is an example.) To preserve semantics we'd have to say + x `seq` error Bool "Inaccessible case" + but the 'seq' is just a case, so we are back to square 1. Or I suppose +we could say + x |> UnsafeCoerce T Bool +but that loses all trace of the fact that this originated with an empty +set of alternatives. + +We can use the empty-alternative construct to coerce error values from +one type to another. For example + + f :: Int -> Int + f n = error "urk" + + g :: Int -> (# Char, Bool #) + g x = case f x of { 0 -> ..., n -> ... } + +Then if we inline f in g's RHS we get + case (error Int "urk") of (# Char, Bool #) { ... } +and we can discard the alternatives since the scrutinee is bottom to give + case (error Int "urk") of (# Char, Bool #) {} + +This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #), +if for no other reason that we don't need to instantiate the (~) at an +unboxed type. + + +************************************************************************ +* * + Ticks +* * +************************************************************************ +-} + +-- | Allows attaching extra information to points in expressions + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +data Tickish id = + -- | An @{-# SCC #-}@ profiling annotation, either automatically + -- added by the desugarer as a result of -auto-all, or added by + -- the user. + ProfNote { + profNoteCC :: CostCentre, -- ^ the cost centre + profNoteCount :: !Bool, -- ^ bump the entry count? + profNoteScope :: !Bool -- ^ scopes over the enclosed expression + -- (i.e. not just a tick) + } + + -- | A "tick" used by HPC to track the execution of each + -- subexpression in the original source code. + | HpcTick { + tickModule :: Module, + tickId :: !Int + } + + -- | A breakpoint for the GHCi debugger. This behaves like an HPC + -- tick, but has a list of free variables which will be available + -- for inspection in GHCi when the program stops at the breakpoint. + -- + -- NB. we must take account of these Ids when (a) counting free variables, + -- and (b) substituting (don't substitute for them) + | Breakpoint + { breakpointId :: !Int + , breakpointFVs :: [id] -- ^ the order of this list is important: + -- it matches the order of the lists in the + -- appropriate entry in HscTypes.ModBreaks. + -- + -- Careful about substitution! See + -- Note [substTickish] in CoreSubst. + } + + deriving (Eq, Ord, Data, Typeable) + + +-- | A "counting tick" (where tickishCounts is True) is one that +-- counts evaluations in some way. We cannot discard a counting tick, +-- and the compiler should preserve the number of counting ticks as +-- far as possible. +-- +-- However, we still allow the simplifier to increase or decrease +-- sharing, so in practice the actual number of ticks may vary, except +-- that we never change the value from zero to non-zero or vice versa. +-- +tickishCounts :: Tickish id -> Bool +tickishCounts n@ProfNote{} = profNoteCount n +tickishCounts HpcTick{} = True +tickishCounts Breakpoint{} = True + +tickishScoped :: Tickish id -> Bool +tickishScoped n@ProfNote{} = profNoteScope n +tickishScoped HpcTick{} = False +tickishScoped Breakpoint{} = True + -- Breakpoints are scoped: eventually we're going to do call + -- stacks, but also this helps prevent the simplifier from moving + -- breakpoints around and changing their result type (see #1531). + +mkNoCount :: Tickish id -> Tickish id +mkNoCount n@ProfNote{} = n {profNoteCount = False} +mkNoCount Breakpoint{} = panic "mkNoCount: Breakpoint" -- cannot split a BP +mkNoCount HpcTick{} = panic "mkNoCount: HpcTick" + +mkNoScope :: Tickish id -> Tickish id +mkNoScope n@ProfNote{} = n {profNoteScope = False} +mkNoScope Breakpoint{} = panic "mkNoScope: Breakpoint" -- cannot split a BP +mkNoScope HpcTick{} = panic "mkNoScope: HpcTick" + +-- | Return True if this source annotation compiles to some code, or will +-- disappear before the backend. +tickishIsCode :: Tickish id -> Bool +tickishIsCode _tickish = True -- all of them for now + +-- | Return True if this Tick can be split into (tick,scope) parts with +-- 'mkNoScope' and 'mkNoCount' respectively. +tickishCanSplit :: Tickish Id -> Bool +tickishCanSplit Breakpoint{} = False +tickishCanSplit HpcTick{} = False +tickishCanSplit _ = True + +{- +************************************************************************ +* * +\subsection{Transformation rules} +* * +************************************************************************ + +The CoreRule type and its friends are dealt with mainly in CoreRules, +but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. +-} + +-- | A 'CoreRule' is: +-- +-- * \"Local\" if the function it is a rule for is defined in the +-- same module as the rule itself. +-- +-- * \"Orphan\" if nothing on the LHS is defined in the same module +-- as the rule itself +data CoreRule + = Rule { + ru_name :: RuleName, -- ^ Name of the rule, for communication with the user + ru_act :: Activation, -- ^ When the rule is active + + -- Rough-matching stuff + -- see comments with InstEnv.ClsInst( is_cls, is_rough ) + ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule + ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side + + -- Proper-matching stuff + -- see comments with InstEnv.ClsInst( is_tvs, is_tys ) + ru_bndrs :: [CoreBndr], -- ^ Variables quantified over + ru_args :: [CoreExpr], -- ^ Left hand side arguments + + -- And the right-hand side + ru_rhs :: CoreExpr, -- ^ Right hand side of the rule + -- Occurrence info is guaranteed correct + -- See Note [OccInfo in unfoldings and rules] + + -- Locality + ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated + -- @False@ <=> generated at the users behest + -- Main effect: reporting of orphan-hood + + ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is + -- defined in the same module as the rule + -- and is not an implicit 'Id' (like a record selector, + -- class operation, or data constructor) + + -- NB: ru_local is *not* used to decide orphan-hood + -- c.g. MkIface.coreRuleToIfaceRule + } + + -- | Built-in rules are used for constant folding + -- and suchlike. They have no free variables. + | BuiltinRule { + ru_name :: RuleName, -- ^ As above + ru_fn :: Name, -- ^ As above + ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, + -- if it fires, including type arguments + ru_try :: RuleFun + -- ^ This function does the rewrite. It given too many + -- arguments, it simply discards them; the returned 'CoreExpr' + -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args + } + -- See Note [Extra args in rule matching] in Rules.lhs + +type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr +type InScopeEnv = (InScopeSet, IdUnfoldingFun) + +type IdUnfoldingFun = Id -> Unfolding +-- A function that embodies how to unfold an Id if you need +-- to do that in the Rule. The reason we need to pass this info in +-- is that whether an Id is unfoldable depends on the simplifier phase + +isBuiltinRule :: CoreRule -> Bool +isBuiltinRule (BuiltinRule {}) = True +isBuiltinRule _ = False + +isAutoRule :: CoreRule -> Bool +isAutoRule (BuiltinRule {}) = False +isAutoRule (Rule { ru_auto = is_auto }) = is_auto + +-- | The number of arguments the 'ru_fn' must be applied +-- to before the rule can match on it +ruleArity :: CoreRule -> Int +ruleArity (BuiltinRule {ru_nargs = n}) = n +ruleArity (Rule {ru_args = args}) = length args + +ruleName :: CoreRule -> RuleName +ruleName = ru_name + +ruleActivation :: CoreRule -> Activation +ruleActivation (BuiltinRule { }) = AlwaysActive +ruleActivation (Rule { ru_act = act }) = act + +-- | The 'Name' of the 'Id.Id' at the head of the rule left hand side +ruleIdName :: CoreRule -> Name +ruleIdName = ru_fn + +isLocalRule :: CoreRule -> Bool +isLocalRule = ru_local + +-- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side +setRuleIdName :: Name -> CoreRule -> CoreRule +setRuleIdName nm ru = ru { ru_fn = nm } + +{- +************************************************************************ +* * +\subsection{Vectorisation declarations} +* * +************************************************************************ + +Representation of desugared vectorisation declarations that are fed to the vectoriser (via +'ModGuts'). +-} + +data CoreVect = Vect Id CoreExpr + | NoVect Id + | VectType Bool TyCon (Maybe TyCon) + | VectClass TyCon -- class tycon + | VectInst Id -- instance dfun (always SCALAR) !!!FIXME: should be superfluous now + +{- +************************************************************************ +* * + Unfoldings +* * +************************************************************************ + +The @Unfolding@ type is declared here to avoid numerous loops +-} + +-- | Records the /unfolding/ of an identifier, which is approximately the form the +-- identifier would have if we substituted its definition in for the identifier. +-- This type should be treated as abstract everywhere except in "CoreUnfold" +data Unfolding + = NoUnfolding -- ^ We have no information about the unfolding + + | OtherCon [AltCon] -- ^ It ain't one of these constructors. + -- @OtherCon xs@ also indicates that something has been evaluated + -- and hence there's no point in re-evaluating it. + -- @OtherCon []@ is used even for non-data-type values + -- to indicated evaluated-ness. Notably: + -- + -- > data C = C !(Int -> Int) + -- > case x of { C f -> ... } + -- + -- Here, @f@ gets an @OtherCon []@ unfolding. + + | DFunUnfolding { -- The Unfolding of a DFunId + -- See Note [DFun unfoldings] + -- df = /\a1..am. \d1..dn. MkD t1 .. tk + -- (op1 a1..am d1..dn) + -- (op2 a1..am d1..dn) + df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] + df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) + df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, + } -- in positional order + + | CoreUnfolding { -- An unfolding for an Id with no pragma, + -- or perhaps a NOINLINE pragma + -- (For NOINLINE, the phase, if any, is in the + -- InlinePragInfo for this Id.) + uf_tmpl :: CoreExpr, -- Template; occurrence info is correct + uf_src :: UnfoldingSource, -- Where the unfolding came from + uf_is_top :: Bool, -- True <=> top level binding + uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard + -- a `seq` on this variable + uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function + -- Cached version of exprIsConLike + uf_is_work_free :: Bool, -- True <=> doesn't waste (much) work to expand + -- inside an inlining + -- Cached version of exprIsCheap + uf_expandable :: Bool, -- True <=> can expand in RULE matching + -- Cached version of exprIsExpandable + uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. + } + -- ^ An unfolding with redundant cached information. Parameters: + -- + -- uf_tmpl: Template used to perform unfolding; + -- NB: Occurrence info is guaranteed correct: + -- see Note [OccInfo in unfoldings and rules] + -- + -- uf_is_top: Is this a top level binding? + -- + -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on + -- this variable + -- + -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining? + -- Basically this is a cached version of 'exprIsWorkFree' + -- + -- uf_guidance: Tells us about the /size/ of the unfolding template + + +------------------------------------------------ +data UnfoldingSource + = -- See also Note [Historical note: unfoldings for wrappers] + + InlineRhs -- The current rhs of the function + -- Replace uf_tmpl each time around + + | InlineStable -- From an INLINE or INLINABLE pragma + -- INLINE if guidance is UnfWhen + -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever + -- (well, technically an INLINABLE might be made + -- UnfWhen if it was small enough, and then + -- it will behave like INLINE outside the current + -- module, but that is the way automatic unfoldings + -- work so it is consistent with the intended + -- meaning of INLINABLE). + -- + -- uf_tmpl may change, but only as a result of + -- gentle simplification, it doesn't get updated + -- to the current RHS during compilation as with + -- InlineRhs. + -- + -- See Note [InlineRules] + + | InlineCompulsory -- Something that *has* no binding, so you *must* inline it + -- Only a few primop-like things have this property + -- (see MkId.lhs, calls to mkCompulsoryUnfolding). + -- Inline absolutely always, however boring the context. + + + +-- | 'UnfoldingGuidance' says when unfolding should take place +data UnfoldingGuidance + = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl + -- Used (a) for small *and* cheap unfoldings + -- (b) for INLINE functions + -- See Note [INLINE for small functions] in CoreUnfold + ug_arity :: Arity, -- Number of value arguments expected + + ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated + ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring + -- So True,True means "always" + } + + | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the + -- result of a simple analysis of the RHS + + ug_args :: [Int], -- Discount if the argument is evaluated. + -- (i.e., a simplification will definitely + -- be possible). One elt of the list per *value* arg. + + ug_size :: Int, -- The "size" of the unfolding. + + ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in + } -- a context (case (thing args) of ...), + -- (where there are the right number of arguments.) + + | UnfNever -- The RHS is big, so don't inline it + +{- +Note [Historical note: unfoldings for wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have a nice clever scheme in interface files for +wrappers. A wrapper's unfolding can be reconstructed from its worker's +id and its strictness. This decreased .hi file size (sometimes +significantly, for modules like GHC.Classes with many high-arity w/w +splits) and had a slight corresponding effect on compile times. + +However, when we added the second demand analysis, this scheme lead to +some Core lint errors. The second analysis could change the strictness +signatures, which sometimes resulted in a wrapper's regenerated +unfolding applying the wrapper to too many arguments. + +Instead of repairing the clever .hi scheme, we abandoned it in favor +of simplicity. The .hi sizes are usually insignificant (excluding the ++1M for base libraries), and compile time barely increases (~+1% for +nofib). The nicer upshot is that the UnfoldingSource no longer mentions +an Id, so, eg, substitutions need not traverse them. + + +Note [DFun unfoldings] +~~~~~~~~~~~~~~~~~~~~~~ +The Arity in a DFunUnfolding is total number of args (type and value) +that the DFun needs to produce a dictionary. That's not necessarily +related to the ordinary arity of the dfun Id, esp if the class has +one method, so the dictionary is represented by a newtype. Example + + class C a where { op :: a -> Int } + instance C a -> C [a] where op xs = op (head xs) + +The instance translates to + + $dfCList :: forall a. C a => C [a] -- Arity 2! + $dfCList = /\a.\d. $copList {a} d |> co + + $copList :: forall a. C a => [a] -> Int -- Arity 2! + $copList = /\a.\d.\xs. op {a} d (head xs) + +Now we might encounter (op (dfCList {ty} d) a1 a2) +and we want the (op (dfList {ty} d)) rule to fire, because $dfCList +has all its arguments, even though its (value) arity is 2. That's +why we record the number of expected arguments in the DFunUnfolding. + +Note that although it's an Arity, it's most convenient for it to give +the *total* number of arguments, both type and value. See the use +site in exprIsConApp_maybe. +-} + +-- Constants for the UnfWhen constructor +needSaturated, unSaturatedOk :: Bool +needSaturated = False +unSaturatedOk = True + +boringCxtNotOk, boringCxtOk :: Bool +boringCxtOk = True +boringCxtNotOk = False + +------------------------------------------------ +noUnfolding :: Unfolding +-- ^ There is no known 'Unfolding' +evaldUnfolding :: Unfolding +-- ^ This unfolding marks the associated thing as being evaluated + +noUnfolding = NoUnfolding +evaldUnfolding = OtherCon [] + +mkOtherCon :: [AltCon] -> Unfolding +mkOtherCon = OtherCon + +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 _ = () + +isStableSource :: UnfoldingSource -> Bool +-- Keep the unfolding template +isStableSource InlineCompulsory = True +isStableSource InlineStable = True +isStableSource InlineRhs = False + +-- | Retrieves the template of an unfolding: panics if none is known +unfoldingTemplate :: Unfolding -> CoreExpr +unfoldingTemplate = uf_tmpl + +-- | Retrieves the template of an unfolding if possible +-- maybeUnfoldingTemplate is used mainly wnen specialising, and we do +-- want to specialise DFuns, so it's important to return a template +-- for DFunUnfoldings +maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr +maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) + = Just expr +maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args)) +maybeUnfoldingTemplate _ + = Nothing + +-- | The constructors that the unfolding could never be: +-- returns @[]@ if no information is available +otherCons :: Unfolding -> [AltCon] +otherCons (OtherCon cons) = cons +otherCons _ = [] + +-- | Determines if it is certainly the case that the unfolding will +-- yield a value (something in HNF): returns @False@ if unsure +isValueUnfolding :: Unfolding -> Bool + -- Returns False for OtherCon +isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald +isValueUnfolding _ = False + +-- | Determines if it possibly the case that the unfolding will +-- yield a value. Unlike 'isValueUnfolding' it returns @True@ +-- for 'OtherCon' +isEvaldUnfolding :: Unfolding -> Bool + -- Returns True for OtherCon +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald +isEvaldUnfolding _ = False + +-- | @True@ if the unfolding is a constructor application, the application +-- of a CONLIKE function or 'OtherCon' +isConLikeUnfolding :: Unfolding -> Bool +isConLikeUnfolding (OtherCon _) = True +isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con +isConLikeUnfolding _ = False + +-- | Is the thing we will unfold into certainly cheap? +isCheapUnfolding :: Unfolding -> Bool +isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf +isCheapUnfolding _ = False + +isExpandableUnfolding :: Unfolding -> Bool +isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable +isExpandableUnfolding _ = False + +expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr +-- Expand an expandable unfolding; this is used in rule matching +-- See Note [Expanding variables] in Rules.lhs +-- The key point here is that CONLIKE things can be expanded +expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs +expandUnfolding_maybe _ = Nothing + +hasStableCoreUnfolding_maybe :: Unfolding -> Maybe Bool +-- Just True <=> has stable inlining, very keen to inline (eg. INLINE pragma) +-- Just False <=> has stable inlining, open to inlining it (eg. INLINEABLE pragma) +-- Nothing <=> not stable, or cannot inline it anyway +hasStableCoreUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) + | isStableSource src + = case guide of + UnfWhen {} -> Just True + UnfIfGoodArgs {} -> Just False + UnfNever -> Nothing +hasStableCoreUnfolding_maybe _ = Nothing + +isCompulsoryUnfolding :: Unfolding -> Bool +isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True +isCompulsoryUnfolding _ = False + +isStableUnfolding :: Unfolding -> Bool +-- True of unfoldings that should not be overwritten +-- by a CoreUnfolding for the RHS of a let-binding +isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src +isStableUnfolding (DFunUnfolding {}) = True +isStableUnfolding _ = False + +isClosedUnfolding :: Unfolding -> Bool -- No free variables +isClosedUnfolding (CoreUnfolding {}) = False +isClosedUnfolding (DFunUnfolding {}) = False +isClosedUnfolding _ = True + +-- | Only returns False if there is no unfolding information available at all +hasSomeUnfolding :: Unfolding -> Bool +hasSomeUnfolding NoUnfolding = False +hasSomeUnfolding _ = True + +neverUnfoldGuidance :: UnfoldingGuidance -> Bool +neverUnfoldGuidance UnfNever = True +neverUnfoldGuidance _ = False + +canUnfold :: Unfolding -> Bool +canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) +canUnfold _ = False + +{- +Note [InlineRules] +~~~~~~~~~~~~~~~~~ +When you say + {-# INLINE f #-} + f x = +you intend that calls (f e) are replaced by [e/x] So we +should capture (\x.) in the Unfolding of 'f', and never meddle +with it. Meanwhile, we can optimise to our heart's content, +leaving the original unfolding intact in Unfolding of 'f'. For example + all xs = foldr (&&) True xs + any p = all . map p {-# INLINE any #-} +We optimise any's RHS fully, but leave the InlineRule saying "all . map p", +which deforests well at the call site. + +So INLINE pragma gives rise to an InlineRule, which captures the original RHS. + +Moreover, it's only used when 'f' is applied to the +specified number of arguments; that is, the number of argument on +the LHS of the '=' sign in the original source definition. +For example, (.) is now defined in the libraries like this + {-# INLINE (.) #-} + (.) f g = \x -> f (g x) +so that it'll inline when applied to two arguments. If 'x' appeared +on the left, thus + (.) f g x = f (g x) +it'd only inline when applied to three arguments. This slightly-experimental +change was requested by Roman, but it seems to make sense. + +See also Note [Inlining an InlineRule] in CoreUnfold. + + +Note [OccInfo in unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In unfoldings and rules, we guarantee that the template is occ-analysed, +so that the occurrence info on the binders is correct. This is important, +because the Simplifier does not re-analyse the template when using it. If +the occurrence info is wrong + - We may get more simpifier iterations than necessary, because + once-occ info isn't there + - More seriously, we may get an infinite loop if there's a Rec + without a loop breaker marked + + +************************************************************************ +* * + AltCon +* * +************************************************************************ +-} + +-- The Ord is needed for the FiniteMap used in the lookForConstructor +-- in SimplEnv. If you declared that lookForConstructor *ignores* +-- constructor-applications with LitArg args, then you could get +-- rid of this Ord. + +instance Outputable AltCon where + ppr (DataAlt dc) = ppr dc + ppr (LitAlt lit) = ppr lit + ppr DEFAULT = ptext (sLit "__DEFAULT") + +cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering +cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 + +ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool +ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT + +cmpAltCon :: AltCon -> AltCon -> Ordering +-- ^ Compares 'AltCon's within a single list of alternatives +cmpAltCon DEFAULT DEFAULT = EQ +cmpAltCon DEFAULT _ = LT + +cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2 +cmpAltCon (DataAlt _) DEFAULT = GT +cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2 +cmpAltCon (LitAlt _) DEFAULT = GT + +cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> + ppr con1 <+> ppr con2 ) + LT + +{- +************************************************************************ +* * +\subsection{Useful synonyms} +* * +************************************************************************ + +Note [CoreProgram] +~~~~~~~~~~~~~~~~~~ +The top level bindings of a program, a CoreProgram, are represented as +a list of CoreBind + + * Later bindings in the list can refer to earlier ones, but not vice + versa. So this is OK + NonRec { x = 4 } + Rec { p = ...q...x... + ; q = ...p...x } + Rec { f = ...p..x..f.. } + NonRec { g = ..f..q...x.. } + But it would NOT be ok for 'f' to refer to 'g'. + + * The occurrence analyser does strongly-connected component analysis + on each Rec binding, and splits it into a sequence of smaller + bindings where possible. So the program typically starts life as a + single giant Rec, which is then dependency-analysed into smaller + chunks. +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +type CoreProgram = [CoreBind] -- See Note [CoreProgram] + +-- | The common case for the type of binders and variables when +-- we are manipulating the Core language within GHC +type CoreBndr = Var +-- | Expressions where binders are 'CoreBndr's +type CoreExpr = Expr CoreBndr +-- | Argument expressions where binders are 'CoreBndr's +type CoreArg = Arg CoreBndr +-- | Binding groups where binders are 'CoreBndr's +type CoreBind = Bind CoreBndr +-- | Case alternatives where binders are 'CoreBndr's +type CoreAlt = Alt CoreBndr + +{- +************************************************************************ +* * +\subsection{Tagging} +* * +************************************************************************ +-} + +-- | Binders are /tagged/ with a t +data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" + +type TaggedBind t = Bind (TaggedBndr t) +type TaggedExpr t = Expr (TaggedBndr t) +type TaggedArg t = Arg (TaggedBndr t) +type TaggedAlt t = Alt (TaggedBndr t) + +instance Outputable b => Outputable (TaggedBndr b) where + ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>' + +instance Outputable b => OutputableBndr (TaggedBndr b) where + pprBndr _ b = ppr b -- Simple + pprInfixOcc b = ppr b + pprPrefixOcc b = ppr b + +deTagExpr :: TaggedExpr t -> CoreExpr +deTagExpr (Var v) = Var v +deTagExpr (Lit l) = Lit l +deTagExpr (Type ty) = Type ty +deTagExpr (Coercion co) = Coercion co +deTagExpr (App e1 e2) = App (deTagExpr e1) (deTagExpr e2) +deTagExpr (Lam (TB b _) e) = Lam b (deTagExpr e) +deTagExpr (Let bind body) = Let (deTagBind bind) (deTagExpr body) +deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts) +deTagExpr (Tick t e) = Tick t (deTagExpr e) +deTagExpr (Cast e co) = Cast (deTagExpr e) co + +deTagBind :: TaggedBind t -> CoreBind +deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs) +deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs] + +deTagAlt :: TaggedAlt t -> CoreAlt +deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs) + +{- +************************************************************************ +* * +\subsection{Core-constructing functions with checking} +* * +************************************************************************ +-} + +-- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to +-- use 'MkCore.mkCoreApps' if possible +mkApps :: Expr b -> [Arg b] -> Expr b +-- | Apply a list of type argument expressions to a function expression in a nested fashion +mkTyApps :: Expr b -> [Type] -> Expr b +-- | Apply a list of coercion argument expressions to a function expression in a nested fashion +mkCoApps :: Expr b -> [Coercion] -> Expr b +-- | Apply a list of type or value variables to a function expression in a nested fashion +mkVarApps :: Expr b -> [Var] -> Expr b +-- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to +-- use 'MkCore.mkCoreConApps' if possible +mkConApp :: DataCon -> [Arg b] -> Expr b + +mkApps f args = foldl App f args +mkTyApps f args = foldl (\ e a -> App e (Type a)) f args +mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args +mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars +mkConApp con args = mkApps (Var (dataConWorkId con)) args + +mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b +mkConApp2 con tys arg_ids = Var (dataConWorkId con) + `mkApps` map Type tys + `mkApps` map varToCoreExpr arg_ids + + +-- | Create a machine integer literal expression of type @Int#@ from an @Integer@. +-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' +mkIntLit :: DynFlags -> Integer -> Expr b +-- | Create a machine integer literal expression of type @Int#@ from an @Int@. +-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' +mkIntLitInt :: DynFlags -> Int -> Expr b + +mkIntLit dflags n = Lit (mkMachInt dflags n) +mkIntLitInt dflags n = Lit (mkMachInt dflags (toInteger n)) + +-- | Create a machine word literal expression of type @Word#@ from an @Integer@. +-- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' +mkWordLit :: DynFlags -> Integer -> Expr b +-- | Create a machine word literal expression of type @Word#@ from a @Word@. +-- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' +mkWordLitWord :: DynFlags -> Word -> Expr b + +mkWordLit dflags w = Lit (mkMachWord dflags w) +mkWordLitWord dflags w = Lit (mkMachWord dflags (toInteger w)) + +mkWord64LitWord64 :: Word64 -> Expr b +mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w)) + +mkInt64LitInt64 :: Int64 -> Expr b +mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w)) + +-- | Create a machine character literal expression of type @Char#@. +-- If you want an expression of type @Char@ use 'MkCore.mkCharExpr' +mkCharLit :: Char -> Expr b +-- | Create a machine string literal expression of type @Addr#@. +-- If you want an expression of type @String@ use 'MkCore.mkStringExpr' +mkStringLit :: String -> Expr b + +mkCharLit c = Lit (mkMachChar c) +mkStringLit s = Lit (mkMachString s) + +-- | Create a machine single precision literal expression of type @Float#@ from a @Rational@. +-- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' +mkFloatLit :: Rational -> Expr b +-- | Create a machine single precision literal expression of type @Float#@ from a @Float@. +-- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' +mkFloatLitFloat :: Float -> Expr b + +mkFloatLit f = Lit (mkMachFloat f) +mkFloatLitFloat f = Lit (mkMachFloat (toRational f)) + +-- | Create a machine double precision literal expression of type @Double#@ from a @Rational@. +-- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' +mkDoubleLit :: Rational -> Expr b +-- | Create a machine double precision literal expression of type @Double#@ from a @Double@. +-- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' +mkDoubleLitDouble :: Double -> Expr b + +mkDoubleLit d = Lit (mkMachDouble d) +mkDoubleLitDouble d = Lit (mkMachDouble (toRational d)) + +-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes +-- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if +-- possible, which does guarantee the invariant +mkLets :: [Bind b] -> Expr b -> Expr b +-- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to +-- use 'MkCore.mkCoreLams' if possible +mkLams :: [b] -> Expr b -> Expr b + +mkLams binders body = foldr Lam body binders +mkLets binds body = foldr Let body binds + + +-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", +-- this can only be used to bind something in a non-recursive @let@ expression +mkTyBind :: TyVar -> Type -> CoreBind +mkTyBind tv ty = NonRec tv (Type ty) + +-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", +-- this can only be used to bind something in a non-recursive @let@ expression +mkCoBind :: CoVar -> Coercion -> CoreBind +mkCoBind cv co = NonRec cv (Coercion co) + +-- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately +varToCoreExpr :: CoreBndr -> Expr b +varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) + | isCoVar v = Coercion (mkCoVarCo v) + | otherwise = ASSERT( isId v ) Var v + +varsToCoreExprs :: [CoreBndr] -> [Expr b] +varsToCoreExprs vs = map varToCoreExpr vs + +{- +************************************************************************ +* * +\subsection{Simple access functions} +* * +************************************************************************ +-} + +-- | Extract every variable by this group +bindersOf :: Bind b -> [b] +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs +bindersOf (NonRec binder _) = [binder] +bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] + +-- | 'bindersOf' applied to a list of binding groups +bindersOfBinds :: [Bind b] -> [b] +bindersOfBinds binds = foldr ((++) . bindersOf) [] binds + +rhssOfBind :: Bind b -> [Expr b] +rhssOfBind (NonRec _ rhs) = [rhs] +rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] + +rhssOfAlts :: [Alt b] -> [Expr b] +rhssOfAlts alts = [e | (_,_,e) <- alts] + +-- | Collapse all the bindings in the supplied groups into a single +-- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group +flattenBinds :: [Bind b] -> [(b, Expr b)] +flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds +flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds +flattenBinds [] = [] + +-- | We often want to strip off leading lambdas before getting down to +-- business. This function is your friend. +collectBinders :: Expr b -> ([b], Expr b) +-- | Collect as many type bindings as possible from the front of a nested lambda +collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) +-- | Collect as many value bindings as possible from the front of a nested lambda +collectValBinders :: CoreExpr -> ([Id], CoreExpr) +-- | Collect type binders from the front of the lambda first, +-- then follow up by collecting as many value bindings as possible +-- from the resulting stripped expression +collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) + +collectBinders expr + = go [] expr + where + go bs (Lam b e) = go (b:bs) e + go bs e = (reverse bs, e) + +collectTyAndValBinders expr + = (tvs, ids, body) + where + (tvs, body1) = collectTyBinders expr + (ids, body) = collectValBinders body1 + +collectTyBinders expr + = go [] expr + where + go tvs (Lam b e) | isTyVar b = go (b:tvs) e + go tvs e = (reverse tvs, e) + +collectValBinders expr + = go [] expr + where + go ids (Lam b e) | isId b = go (b:ids) e + go ids body = (reverse ids, body) + +-- | Takes a nested application expression and returns the the function +-- being applied and the arguments to which it is applied +collectArgs :: Expr b -> (Expr b, [Arg b]) +collectArgs expr + = go expr [] + where + go (App f a) as = go f (a:as) + go e as = (e, as) + +{- +************************************************************************ +* * +\subsection{Predicates} +* * +************************************************************************ + +At one time we optionally carried type arguments through to runtime. +@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime, +i.e. if type applications are actual lambdas because types are kept around +at runtime. Similarly isRuntimeArg. +-} + +-- | Will this variable exist at runtime? +isRuntimeVar :: Var -> Bool +isRuntimeVar = isId + +-- | Will this argument expression exist at runtime? +isRuntimeArg :: CoreExpr -> Bool +isRuntimeArg = isValArg + +-- | Returns @True@ for value arguments, false for type args +-- NB: coercions are value arguments (zero width, to be sure, +-- like State#, but still value args). +isValArg :: Expr b -> Bool +isValArg e = not (isTypeArg e) + +-- | Returns @True@ iff the expression is a 'Type' or 'Coercion' +-- expression at its top level +isTyCoArg :: Expr b -> Bool +isTyCoArg (Type {}) = True +isTyCoArg (Coercion {}) = True +isTyCoArg _ = False + +-- | Returns @True@ iff the expression is a 'Type' expression at its +-- top level. Note this does NOT include 'Coercion's. +isTypeArg :: Expr b -> Bool +isTypeArg (Type {}) = True +isTypeArg _ = False + +-- | The number of binders that bind values rather than types +valBndrCount :: [CoreBndr] -> Int +valBndrCount = count isId + +-- | The number of argument expressions that are values rather than types at their top level +valArgCount :: [Arg b] -> Int +valArgCount = count isValArg + +{- +************************************************************************ +* * +\subsection{Seq stuff} +* * +************************************************************************ +-} + +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 + +seqBndr :: CoreBndr -> () +seqBndr b = b `seq` () + +seqBndrs :: [CoreBndr] -> () +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs 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 + +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 + +{- +************************************************************************ +* * +\subsection{Annotated core} +* * +************************************************************************ +-} + +-- | Annotated core: allows annotation at every node in the tree +type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) + +-- | A clone of the 'Expr' type but allowing annotation at every tree node +data AnnExpr' bndr annot + = AnnVar Id + | AnnLit Literal + | AnnLam bndr (AnnExpr bndr annot) + | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) + | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] + | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) + | AnnCast (AnnExpr bndr annot) (annot, Coercion) + -- Put an annotation on the (root of) the coercion + | AnnTick (Tickish Id) (AnnExpr bndr annot) + | AnnType Type + | AnnCoercion Coercion + +-- | A clone of the 'Alt' type but allowing annotation at every tree node +type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) + +-- | A clone of the 'Bind' type but allowing annotation at every tree node +data AnnBind bndr annot + = AnnNonRec bndr (AnnExpr bndr annot) + | AnnRec [(bndr, AnnExpr bndr annot)] + +-- | Takes a nested application expression and returns the the function +-- being applied and the arguments to which it is applied +collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) +collectAnnArgs expr + = go expr [] + where + go (_, AnnApp f a) as = go f (a:as) + go e as = (e, as) + +deAnnotate :: AnnExpr bndr annot -> Expr bndr +deAnnotate (_, e) = deAnnotate' e + +deAnnotate' :: AnnExpr' bndr annot -> Expr bndr +deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnCoercion co) = Coercion co +deAnnotate' (AnnVar v) = Var v +deAnnotate' (AnnLit lit) = Lit lit +deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) +deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) +deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co +deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body) + +deAnnotate' (AnnLet bind body) + = Let (deAnnBind bind) (deAnnotate body) + where + deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) + deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] + +deAnnotate' (AnnCase scrut v t alts) + = Case (deAnnotate scrut) v t (map deAnnAlt alts) + +deAnnAlt :: AnnAlt bndr annot -> Alt bndr +deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) + +-- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr' +collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) +collectAnnBndrs e + = collect [] e + where + collect bs (_, AnnLam b body) = collect (b:bs) body + collect bs body = (reverse bs, body) diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs deleted file mode 100644 index 47418e22ec..0000000000 --- a/compiler/coreSyn/CoreSyn.lhs +++ /dev/null @@ -1,1523 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -\begin{code} -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} - --- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection -module CoreSyn ( - -- * Main data types - Expr(..), Alt, Bind(..), AltCon(..), Arg, Tickish(..), - CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, - TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, - - -- ** 'Expr' construction - mkLets, mkLams, - mkApps, mkTyApps, mkCoApps, mkVarApps, - - mkIntLit, mkIntLitInt, - mkWordLit, mkWordLitWord, - mkWord64LitWord64, mkInt64LitInt64, - mkCharLit, mkStringLit, - mkFloatLit, mkFloatLitFloat, - mkDoubleLit, mkDoubleLitDouble, - - mkConApp, mkConApp2, mkTyBind, mkCoBind, - varToCoreExpr, varsToCoreExprs, - - isId, cmpAltCon, cmpAlt, ltAlt, - - -- ** Simple 'Expr' access functions and predicates - bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, - collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, - collectArgs, flattenBinds, - - isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount, - isRuntimeArg, isRuntimeVar, - - tickishCounts, tickishScoped, tickishIsCode, mkNoCount, mkNoScope, - tickishCanSplit, - - -- * Unfolding data types - Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), - - -- ** Constructing 'Unfolding's - noUnfolding, evaldUnfolding, mkOtherCon, - unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, - - -- ** Predicates and deconstruction on 'Unfolding' - unfoldingTemplate, expandUnfolding_maybe, - maybeUnfoldingTemplate, otherCons, - isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, - isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, - isStableUnfolding, hasStableCoreUnfolding_maybe, - isClosedUnfolding, hasSomeUnfolding, - canUnfold, neverUnfoldGuidance, isStableSource, - - -- * Strictness - seqExpr, seqExprs, seqUnfolding, - - -- * Annotated expression data types - AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, - - -- ** Operations on annotated expressions - collectAnnArgs, - - -- ** Operations on annotations - deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs, - - -- * Core rule data types - CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only - RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, - - -- ** Operations on 'CoreRule's - seqRules, ruleArity, ruleName, ruleIdName, ruleActivation, - setRuleIdName, - isBuiltinRule, isLocalRule, isAutoRule, - - -- * Core vectorisation declarations data type - CoreVect(..) - ) where - -#include "HsVersions.h" - -import CostCentre -import VarEnv( InScopeSet ) -import Var -import Type -import Coercion -import Name -import Literal -import DataCon -import Module -import TyCon -import BasicTypes -import DynFlags -import FastString -import Outputable -import Util - -import Data.Data hiding (TyCon) -import Data.Int -import Data.Word - -infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` --- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) -\end{code} - -%************************************************************************ -%* * -\subsection{The main data types} -%* * -%************************************************************************ - -These data types are the heart of the compiler - -\begin{code} --- | This is the data type that represents GHCs core intermediate language. Currently --- GHC uses System FC for this purpose, --- which is closely related to the simpler and better known System F . --- --- We get from Haskell source to this Core language in a number of stages: --- --- 1. The source code is parsed into an abstract syntax tree, which is represented --- by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames' --- --- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName' --- (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical. --- For example, this program: --- --- @ --- f x = let f x = x + 1 --- in f (x - 2) --- @ --- --- Would be renamed by having 'Unique's attached so it looked something like this: --- --- @ --- f_1 x_2 = let f_3 x_4 = x_4 + 1 --- in f_3 (x_2 - 2) --- @ --- But see Note [Shadowing] below. --- --- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating --- type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names. --- --- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into --- this 'Expr' type, which has far fewer constructors and hence is easier to perform --- optimization, analysis and code generation on. --- --- The type parameter @b@ is for the type of binders in the expression tree. --- --- The language consists of the following elements: --- --- * Variables --- --- * Primitive literals --- --- * Applications: note that the argument may be a 'Type'. --- --- See "CoreSyn#let_app_invariant" for another invariant --- --- * Lambda abstraction --- --- * Recursive and non recursive @let@s. Operationally --- this corresponds to allocating a thunk for the things --- bound and then executing the sub-expression. --- --- #top_level_invariant# --- #letrec_invariant# --- --- The right hand sides of all top-level and recursive @let@s --- /must/ be of lifted type (see "Type#type_classification" for --- the meaning of /lifted/ vs. /unlifted/). --- --- See Note [CoreSyn let/app invariant] --- --- #type_let# --- We allow a /non-recursive/ let to bind a type variable, thus: --- --- > Let (NonRec tv (Type ty)) body --- --- This can be very convenient for postponing type substitutions until --- the next run of the simplifier. --- --- At the moment, the rest of the compiler only deals with type-let --- in a Let expression, rather than at top level. We may want to revist --- this choice. --- --- * Case split. Operationally this corresponds to evaluating --- the scrutinee (expression examined) to weak head normal form --- and then examining at most one level of resulting constructor (i.e. you --- cannot do nested pattern matching directly with this). --- --- The binder gets bound to the value of the scrutinee, --- and the 'Type' must be that of all the case alternatives --- --- #case_invariants# --- This is one of the more complicated elements of the Core language, --- and comes with a number of restrictions: --- --- 1. The list of alternatives may be empty; --- See Note [Empty case alternatives] --- --- 2. The 'DEFAULT' case alternative must be first in the list, --- if it occurs at all. --- --- 3. The remaining cases are in order of increasing --- tag (for 'DataAlts') or --- lit (for 'LitAlts'). --- This makes finding the relevant constructor easy, --- and makes comparison easier too. --- --- 4. The list of alternatives must be exhaustive. An /exhaustive/ case --- does not necessarily mention all constructors: --- --- @ --- data Foo = Red | Green | Blue --- ... case x of --- Red -> True --- other -> f (case x of --- Green -> ... --- Blue -> ... ) ... --- @ --- --- The inner case does not need a @Red@ alternative, because @x@ --- can't be @Red@ at that program point. --- --- * Cast an expression to a particular type. --- This is used to implement @newtype@s (a @newtype@ constructor or --- destructor just becomes a 'Cast' in Core) and GADTs. --- --- * Notes. These allow general information to be added to expressions --- in the syntax tree --- --- * A type: this should only show up at the top level of an Arg --- --- * A coercion - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.lhs -data Expr b - = Var Id - | Lit Literal - | App (Expr b) (Arg b) - | Lam b (Expr b) - | Let (Bind b) (Expr b) - | Case (Expr b) b Type [Alt b] -- See #case_invariant# - | Cast (Expr b) Coercion - | Tick (Tickish Id) (Expr b) - | Type Type - | Coercion Coercion - deriving (Data, Typeable) - --- | Type synonym for expressions that occur in function argument positions. --- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not -type Arg b = Expr b - --- | A case split alternative. Consists of the constructor leading to the alternative, --- the variables bound from the constructor, and the expression to be executed given that binding. --- The default alternative is @(DEFAULT, [], rhs)@ - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.lhs -type Alt b = (AltCon, [b], Expr b) - --- | A case alternative constructor (i.e. pattern match) - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.lhs -data AltCon - = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@. - -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@ - - | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@ - -- Invariant: always an *unlifted* literal - -- See Note [Literal alternatives] - - | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@ - deriving (Eq, Ord, Data, Typeable) - --- | Binding, used for top level bindings in a module and local bindings in a @let@. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.lhs -data Bind b = NonRec b (Expr b) - | Rec [(b, (Expr b))] - deriving (Data, Typeable) -\end{code} - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -While various passes attempt to rename on-the-fly in a manner that -avoids "shadowing" (thereby simplifying downstream optimizations), -neither the simplifier nor any other pass GUARANTEES that shadowing is -avoided. Thus, all passes SHOULD work fine even in the presence of -arbitrary shadowing in their inputs. - -In particular, scrutinee variables `x` in expressions of the form -`Case e x t` are often renamed to variables with a prefix -"wild_". These "wild" variables may appear in the body of the -case-expression, and further, may be shadowed within the body. - -So the Unique in an Var is not really unique at all. Still, it's very -useful to give a constant-time equality/ordering for Vars, and to give -a key that can be used to make sets of Vars (VarSet), or mappings from -Vars to other things (VarEnv). Moreover, if you do want to eliminate -shadowing, you can give a new Unique to an Id without changing its -printable name, which makes debugging easier. - -Note [Literal alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Literal alternatives (LitAlt lit) are always for *un-lifted* literals. -We have one literal, a literal Integer, that is lifted, and we don't -allow in a LitAlt, because LitAlt cases don't do any evaluation. Also -(see Trac #5603) if you say - case 3 of - S# x -> ... - J# _ _ -> ... -(where S#, J# are the constructors for Integer) we don't want the -simplifier calling findAlt with argument (LitAlt 3). No no. Integer -literals are an opaque encoding of an algebraic data type, not of -an unlifted literal, like all the others. - - --------------------------- CoreSyn INVARIANTS --------------------------- - -Note [CoreSyn top-level invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #toplevel_invariant# - -Note [CoreSyn letrec invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #letrec_invariant# - -Note [CoreSyn let/app invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The let/app invariant - the right hand side of of a non-recursive 'Let', and - the argument of an 'App', - /may/ be of unlifted type, but only if - the expression is ok-for-speculation. - -This means that the let can be floated around -without difficulty. For example, this is OK: - - y::Int# = x +# 1# - -But this is not, as it may affect termination if the -expression is floated out: - - y::Int# = fac 4# - -In this situation you should use @case@ rather than a @let@. The function -'CoreUtils.needsCaseBinding' can help you determine which to generate, or -alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, -which will generate a @case@ if necessary - -Th let/app invariant is initially enforced by DsUtils.mkCoreLet and mkCoreApp - -Note [CoreSyn case invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #case_invariants# - -Note [CoreSyn let goal] -~~~~~~~~~~~~~~~~~~~~~~~ -* The simplifier tries to ensure that if the RHS of a let is a constructor - application, its arguments are trivial, so that the constructor can be - inlined vigorously. - -Note [Type let] -~~~~~~~~~~~~~~~ -See #type_let# - -Note [Empty case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The alternatives of a case expression should be exhaustive. A case expression -can have empty alternatives if (and only if) the scrutinee is bound to raise -an exception or diverge. So: - Case (error Int "Hello") b Bool [] -is fine, and has type Bool. This is one reason we need a type on -the case expression: if the alternatives are empty we can't get the type -from the alternatives! I'll write this - case (error Int "Hello") of Bool {} -with the return type just before the alternatives. - -Here's another 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. Its a bit of a -degnerate situation but we do NOT want to replace - case x of Bool {} --> error Bool "Inaccessible case" -because x might raise an exception, and *that*'s what we want to see! -(Trac #6067 is an example.) To preserve semantics we'd have to say - x `seq` error Bool "Inaccessible case" - but the 'seq' is just a case, so we are back to square 1. Or I suppose -we could say - x |> UnsafeCoerce T Bool -but that loses all trace of the fact that this originated with an empty -set of alternatives. - -We can use the empty-alternative construct to coerce error values from -one type to another. For example - - f :: Int -> Int - f n = error "urk" - - g :: Int -> (# Char, Bool #) - g x = case f x of { 0 -> ..., n -> ... } - -Then if we inline f in g's RHS we get - case (error Int "urk") of (# Char, Bool #) { ... } -and we can discard the alternatives since the scrutinee is bottom to give - case (error Int "urk") of (# Char, Bool #) {} - -This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #), -if for no other reason that we don't need to instantiate the (~) at an -unboxed type. - - -%************************************************************************ -%* * - Ticks -%* * -%************************************************************************ - -\begin{code} --- | Allows attaching extra information to points in expressions - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.lhs -data Tickish id = - -- | An @{-# SCC #-}@ profiling annotation, either automatically - -- added by the desugarer as a result of -auto-all, or added by - -- the user. - ProfNote { - profNoteCC :: CostCentre, -- ^ the cost centre - profNoteCount :: !Bool, -- ^ bump the entry count? - profNoteScope :: !Bool -- ^ scopes over the enclosed expression - -- (i.e. not just a tick) - } - - -- | A "tick" used by HPC to track the execution of each - -- subexpression in the original source code. - | HpcTick { - tickModule :: Module, - tickId :: !Int - } - - -- | A breakpoint for the GHCi debugger. This behaves like an HPC - -- tick, but has a list of free variables which will be available - -- for inspection in GHCi when the program stops at the breakpoint. - -- - -- NB. we must take account of these Ids when (a) counting free variables, - -- and (b) substituting (don't substitute for them) - | Breakpoint - { breakpointId :: !Int - , breakpointFVs :: [id] -- ^ the order of this list is important: - -- it matches the order of the lists in the - -- appropriate entry in HscTypes.ModBreaks. - -- - -- Careful about substitution! See - -- Note [substTickish] in CoreSubst. - } - - deriving (Eq, Ord, Data, Typeable) - - --- | A "counting tick" (where tickishCounts is True) is one that --- counts evaluations in some way. We cannot discard a counting tick, --- and the compiler should preserve the number of counting ticks as --- far as possible. --- --- However, we still allow the simplifier to increase or decrease --- sharing, so in practice the actual number of ticks may vary, except --- that we never change the value from zero to non-zero or vice versa. --- -tickishCounts :: Tickish id -> Bool -tickishCounts n@ProfNote{} = profNoteCount n -tickishCounts HpcTick{} = True -tickishCounts Breakpoint{} = True - -tickishScoped :: Tickish id -> Bool -tickishScoped n@ProfNote{} = profNoteScope n -tickishScoped HpcTick{} = False -tickishScoped Breakpoint{} = True - -- Breakpoints are scoped: eventually we're going to do call - -- stacks, but also this helps prevent the simplifier from moving - -- breakpoints around and changing their result type (see #1531). - -mkNoCount :: Tickish id -> Tickish id -mkNoCount n@ProfNote{} = n {profNoteCount = False} -mkNoCount Breakpoint{} = panic "mkNoCount: Breakpoint" -- cannot split a BP -mkNoCount HpcTick{} = panic "mkNoCount: HpcTick" - -mkNoScope :: Tickish id -> Tickish id -mkNoScope n@ProfNote{} = n {profNoteScope = False} -mkNoScope Breakpoint{} = panic "mkNoScope: Breakpoint" -- cannot split a BP -mkNoScope HpcTick{} = panic "mkNoScope: HpcTick" - --- | Return True if this source annotation compiles to some code, or will --- disappear before the backend. -tickishIsCode :: Tickish id -> Bool -tickishIsCode _tickish = True -- all of them for now - --- | Return True if this Tick can be split into (tick,scope) parts with --- 'mkNoScope' and 'mkNoCount' respectively. -tickishCanSplit :: Tickish Id -> Bool -tickishCanSplit Breakpoint{} = False -tickishCanSplit HpcTick{} = False -tickishCanSplit _ = True -\end{code} - - -%************************************************************************ -%* * -\subsection{Transformation rules} -%* * -%************************************************************************ - -The CoreRule type and its friends are dealt with mainly in CoreRules, -but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. - -\begin{code} --- | A 'CoreRule' is: --- --- * \"Local\" if the function it is a rule for is defined in the --- same module as the rule itself. --- --- * \"Orphan\" if nothing on the LHS is defined in the same module --- as the rule itself -data CoreRule - = Rule { - ru_name :: RuleName, -- ^ Name of the rule, for communication with the user - ru_act :: Activation, -- ^ When the rule is active - - -- Rough-matching stuff - -- see comments with InstEnv.ClsInst( is_cls, is_rough ) - ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule - ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side - - -- Proper-matching stuff - -- see comments with InstEnv.ClsInst( is_tvs, is_tys ) - ru_bndrs :: [CoreBndr], -- ^ Variables quantified over - ru_args :: [CoreExpr], -- ^ Left hand side arguments - - -- And the right-hand side - ru_rhs :: CoreExpr, -- ^ Right hand side of the rule - -- Occurrence info is guaranteed correct - -- See Note [OccInfo in unfoldings and rules] - - -- Locality - ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated - -- @False@ <=> generated at the users behest - -- Main effect: reporting of orphan-hood - - ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is - -- defined in the same module as the rule - -- and is not an implicit 'Id' (like a record selector, - -- class operation, or data constructor) - - -- NB: ru_local is *not* used to decide orphan-hood - -- c.g. MkIface.coreRuleToIfaceRule - } - - -- | Built-in rules are used for constant folding - -- and suchlike. They have no free variables. - | BuiltinRule { - ru_name :: RuleName, -- ^ As above - ru_fn :: Name, -- ^ As above - ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, - -- if it fires, including type arguments - ru_try :: RuleFun - -- ^ This function does the rewrite. It given too many - -- arguments, it simply discards them; the returned 'CoreExpr' - -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args - } - -- See Note [Extra args in rule matching] in Rules.lhs - -type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr -type InScopeEnv = (InScopeSet, IdUnfoldingFun) - -type IdUnfoldingFun = Id -> Unfolding --- A function that embodies how to unfold an Id if you need --- to do that in the Rule. The reason we need to pass this info in --- is that whether an Id is unfoldable depends on the simplifier phase - -isBuiltinRule :: CoreRule -> Bool -isBuiltinRule (BuiltinRule {}) = True -isBuiltinRule _ = False - -isAutoRule :: CoreRule -> Bool -isAutoRule (BuiltinRule {}) = False -isAutoRule (Rule { ru_auto = is_auto }) = is_auto - --- | The number of arguments the 'ru_fn' must be applied --- to before the rule can match on it -ruleArity :: CoreRule -> Int -ruleArity (BuiltinRule {ru_nargs = n}) = n -ruleArity (Rule {ru_args = args}) = length args - -ruleName :: CoreRule -> RuleName -ruleName = ru_name - -ruleActivation :: CoreRule -> Activation -ruleActivation (BuiltinRule { }) = AlwaysActive -ruleActivation (Rule { ru_act = act }) = act - --- | The 'Name' of the 'Id.Id' at the head of the rule left hand side -ruleIdName :: CoreRule -> Name -ruleIdName = ru_fn - -isLocalRule :: CoreRule -> Bool -isLocalRule = ru_local - --- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side -setRuleIdName :: Name -> CoreRule -> CoreRule -setRuleIdName nm ru = ru { ru_fn = nm } -\end{code} - - -%************************************************************************ -%* * -\subsection{Vectorisation declarations} -%* * -%************************************************************************ - -Representation of desugared vectorisation declarations that are fed to the vectoriser (via -'ModGuts'). - -\begin{code} -data CoreVect = Vect Id CoreExpr - | NoVect Id - | VectType Bool TyCon (Maybe TyCon) - | VectClass TyCon -- class tycon - | VectInst Id -- instance dfun (always SCALAR) !!!FIXME: should be superfluous now -\end{code} - - -%************************************************************************ -%* * - Unfoldings -%* * -%************************************************************************ - -The @Unfolding@ type is declared here to avoid numerous loops - -\begin{code} --- | Records the /unfolding/ of an identifier, which is approximately the form the --- identifier would have if we substituted its definition in for the identifier. --- This type should be treated as abstract everywhere except in "CoreUnfold" -data Unfolding - = NoUnfolding -- ^ We have no information about the unfolding - - | OtherCon [AltCon] -- ^ It ain't one of these constructors. - -- @OtherCon xs@ also indicates that something has been evaluated - -- and hence there's no point in re-evaluating it. - -- @OtherCon []@ is used even for non-data-type values - -- to indicated evaluated-ness. Notably: - -- - -- > data C = C !(Int -> Int) - -- > case x of { C f -> ... } - -- - -- Here, @f@ gets an @OtherCon []@ unfolding. - - | DFunUnfolding { -- The Unfolding of a DFunId - -- See Note [DFun unfoldings] - -- df = /\a1..am. \d1..dn. MkD t1 .. tk - -- (op1 a1..am d1..dn) - -- (op2 a1..am d1..dn) - df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] - df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) - df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, - } -- in positional order - - | CoreUnfolding { -- An unfolding for an Id with no pragma, - -- or perhaps a NOINLINE pragma - -- (For NOINLINE, the phase, if any, is in the - -- InlinePragInfo for this Id.) - uf_tmpl :: CoreExpr, -- Template; occurrence info is correct - uf_src :: UnfoldingSource, -- Where the unfolding came from - uf_is_top :: Bool, -- True <=> top level binding - uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard - -- a `seq` on this variable - uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function - -- Cached version of exprIsConLike - uf_is_work_free :: Bool, -- True <=> doesn't waste (much) work to expand - -- inside an inlining - -- Cached version of exprIsCheap - uf_expandable :: Bool, -- True <=> can expand in RULE matching - -- Cached version of exprIsExpandable - uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. - } - -- ^ An unfolding with redundant cached information. Parameters: - -- - -- uf_tmpl: Template used to perform unfolding; - -- NB: Occurrence info is guaranteed correct: - -- see Note [OccInfo in unfoldings and rules] - -- - -- uf_is_top: Is this a top level binding? - -- - -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on - -- this variable - -- - -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining? - -- Basically this is a cached version of 'exprIsWorkFree' - -- - -- uf_guidance: Tells us about the /size/ of the unfolding template - - ------------------------------------------------- -data UnfoldingSource - = -- See also Note [Historical note: unfoldings for wrappers] - - InlineRhs -- The current rhs of the function - -- Replace uf_tmpl each time around - - | InlineStable -- From an INLINE or INLINABLE pragma - -- INLINE if guidance is UnfWhen - -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever - -- (well, technically an INLINABLE might be made - -- UnfWhen if it was small enough, and then - -- it will behave like INLINE outside the current - -- module, but that is the way automatic unfoldings - -- work so it is consistent with the intended - -- meaning of INLINABLE). - -- - -- uf_tmpl may change, but only as a result of - -- gentle simplification, it doesn't get updated - -- to the current RHS during compilation as with - -- InlineRhs. - -- - -- See Note [InlineRules] - - | InlineCompulsory -- Something that *has* no binding, so you *must* inline it - -- Only a few primop-like things have this property - -- (see MkId.lhs, calls to mkCompulsoryUnfolding). - -- Inline absolutely always, however boring the context. - - - --- | 'UnfoldingGuidance' says when unfolding should take place -data UnfoldingGuidance - = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl - -- Used (a) for small *and* cheap unfoldings - -- (b) for INLINE functions - -- See Note [INLINE for small functions] in CoreUnfold - ug_arity :: Arity, -- Number of value arguments expected - - ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated - ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring - -- So True,True means "always" - } - - | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the - -- result of a simple analysis of the RHS - - ug_args :: [Int], -- Discount if the argument is evaluated. - -- (i.e., a simplification will definitely - -- be possible). One elt of the list per *value* arg. - - ug_size :: Int, -- The "size" of the unfolding. - - ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in - } -- a context (case (thing args) of ...), - -- (where there are the right number of arguments.) - - | UnfNever -- The RHS is big, so don't inline it -\end{code} - -Note [Historical note: unfoldings for wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to have a nice clever scheme in interface files for -wrappers. A wrapper's unfolding can be reconstructed from its worker's -id and its strictness. This decreased .hi file size (sometimes -significantly, for modules like GHC.Classes with many high-arity w/w -splits) and had a slight corresponding effect on compile times. - -However, when we added the second demand analysis, this scheme lead to -some Core lint errors. The second analysis could change the strictness -signatures, which sometimes resulted in a wrapper's regenerated -unfolding applying the wrapper to too many arguments. - -Instead of repairing the clever .hi scheme, we abandoned it in favor -of simplicity. The .hi sizes are usually insignificant (excluding the -+1M for base libraries), and compile time barely increases (~+1% for -nofib). The nicer upshot is that the UnfoldingSource no longer mentions -an Id, so, eg, substitutions need not traverse them. - - -Note [DFun unfoldings] -~~~~~~~~~~~~~~~~~~~~~~ -The Arity in a DFunUnfolding is total number of args (type and value) -that the DFun needs to produce a dictionary. That's not necessarily -related to the ordinary arity of the dfun Id, esp if the class has -one method, so the dictionary is represented by a newtype. Example - - class C a where { op :: a -> Int } - instance C a -> C [a] where op xs = op (head xs) - -The instance translates to - - $dfCList :: forall a. C a => C [a] -- Arity 2! - $dfCList = /\a.\d. $copList {a} d |> co - - $copList :: forall a. C a => [a] -> Int -- Arity 2! - $copList = /\a.\d.\xs. op {a} d (head xs) - -Now we might encounter (op (dfCList {ty} d) a1 a2) -and we want the (op (dfList {ty} d)) rule to fire, because $dfCList -has all its arguments, even though its (value) arity is 2. That's -why we record the number of expected arguments in the DFunUnfolding. - -Note that although it's an Arity, it's most convenient for it to give -the *total* number of arguments, both type and value. See the use -site in exprIsConApp_maybe. - -\begin{code} --- Constants for the UnfWhen constructor -needSaturated, unSaturatedOk :: Bool -needSaturated = False -unSaturatedOk = True - -boringCxtNotOk, boringCxtOk :: Bool -boringCxtOk = True -boringCxtNotOk = False - ------------------------------------------------- -noUnfolding :: Unfolding --- ^ There is no known 'Unfolding' -evaldUnfolding :: Unfolding --- ^ This unfolding marks the associated thing as being evaluated - -noUnfolding = NoUnfolding -evaldUnfolding = OtherCon [] - -mkOtherCon :: [AltCon] -> Unfolding -mkOtherCon = OtherCon - -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 _ = () -\end{code} - -\begin{code} -isStableSource :: UnfoldingSource -> Bool --- Keep the unfolding template -isStableSource InlineCompulsory = True -isStableSource InlineStable = True -isStableSource InlineRhs = False - --- | Retrieves the template of an unfolding: panics if none is known -unfoldingTemplate :: Unfolding -> CoreExpr -unfoldingTemplate = uf_tmpl - --- | Retrieves the template of an unfolding if possible --- maybeUnfoldingTemplate is used mainly wnen specialising, and we do --- want to specialise DFuns, so it's important to return a template --- for DFunUnfoldings -maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr -maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) - = Just expr -maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) - = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args)) -maybeUnfoldingTemplate _ - = Nothing - --- | The constructors that the unfolding could never be: --- returns @[]@ if no information is available -otherCons :: Unfolding -> [AltCon] -otherCons (OtherCon cons) = cons -otherCons _ = [] - --- | Determines if it is certainly the case that the unfolding will --- yield a value (something in HNF): returns @False@ if unsure -isValueUnfolding :: Unfolding -> Bool - -- Returns False for OtherCon -isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald -isValueUnfolding _ = False - --- | Determines if it possibly the case that the unfolding will --- yield a value. Unlike 'isValueUnfolding' it returns @True@ --- for 'OtherCon' -isEvaldUnfolding :: Unfolding -> Bool - -- Returns True for OtherCon -isEvaldUnfolding (OtherCon _) = True -isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald -isEvaldUnfolding _ = False - --- | @True@ if the unfolding is a constructor application, the application --- of a CONLIKE function or 'OtherCon' -isConLikeUnfolding :: Unfolding -> Bool -isConLikeUnfolding (OtherCon _) = True -isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con -isConLikeUnfolding _ = False - --- | Is the thing we will unfold into certainly cheap? -isCheapUnfolding :: Unfolding -> Bool -isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf -isCheapUnfolding _ = False - -isExpandableUnfolding :: Unfolding -> Bool -isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable -isExpandableUnfolding _ = False - -expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr --- Expand an expandable unfolding; this is used in rule matching --- See Note [Expanding variables] in Rules.lhs --- The key point here is that CONLIKE things can be expanded -expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs -expandUnfolding_maybe _ = Nothing - -hasStableCoreUnfolding_maybe :: Unfolding -> Maybe Bool --- Just True <=> has stable inlining, very keen to inline (eg. INLINE pragma) --- Just False <=> has stable inlining, open to inlining it (eg. INLINEABLE pragma) --- Nothing <=> not stable, or cannot inline it anyway -hasStableCoreUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) - | isStableSource src - = case guide of - UnfWhen {} -> Just True - UnfIfGoodArgs {} -> Just False - UnfNever -> Nothing -hasStableCoreUnfolding_maybe _ = Nothing - -isCompulsoryUnfolding :: Unfolding -> Bool -isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True -isCompulsoryUnfolding _ = False - -isStableUnfolding :: Unfolding -> Bool --- True of unfoldings that should not be overwritten --- by a CoreUnfolding for the RHS of a let-binding -isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src -isStableUnfolding (DFunUnfolding {}) = True -isStableUnfolding _ = False - -isClosedUnfolding :: Unfolding -> Bool -- No free variables -isClosedUnfolding (CoreUnfolding {}) = False -isClosedUnfolding (DFunUnfolding {}) = False -isClosedUnfolding _ = True - --- | Only returns False if there is no unfolding information available at all -hasSomeUnfolding :: Unfolding -> Bool -hasSomeUnfolding NoUnfolding = False -hasSomeUnfolding _ = True - -neverUnfoldGuidance :: UnfoldingGuidance -> Bool -neverUnfoldGuidance UnfNever = True -neverUnfoldGuidance _ = False - -canUnfold :: Unfolding -> Bool -canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) -canUnfold _ = False -\end{code} - -Note [InlineRules] -~~~~~~~~~~~~~~~~~ -When you say - {-# INLINE f #-} - f x = -you intend that calls (f e) are replaced by [e/x] So we -should capture (\x.) in the Unfolding of 'f', and never meddle -with it. Meanwhile, we can optimise to our heart's content, -leaving the original unfolding intact in Unfolding of 'f'. For example - all xs = foldr (&&) True xs - any p = all . map p {-# INLINE any #-} -We optimise any's RHS fully, but leave the InlineRule saying "all . map p", -which deforests well at the call site. - -So INLINE pragma gives rise to an InlineRule, which captures the original RHS. - -Moreover, it's only used when 'f' is applied to the -specified number of arguments; that is, the number of argument on -the LHS of the '=' sign in the original source definition. -For example, (.) is now defined in the libraries like this - {-# INLINE (.) #-} - (.) f g = \x -> f (g x) -so that it'll inline when applied to two arguments. If 'x' appeared -on the left, thus - (.) f g x = f (g x) -it'd only inline when applied to three arguments. This slightly-experimental -change was requested by Roman, but it seems to make sense. - -See also Note [Inlining an InlineRule] in CoreUnfold. - - -Note [OccInfo in unfoldings and rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In unfoldings and rules, we guarantee that the template is occ-analysed, -so that the occurrence info on the binders is correct. This is important, -because the Simplifier does not re-analyse the template when using it. If -the occurrence info is wrong - - We may get more simpifier iterations than necessary, because - once-occ info isn't there - - More seriously, we may get an infinite loop if there's a Rec - without a loop breaker marked - - -%************************************************************************ -%* * - AltCon -%* * -%************************************************************************ - -\begin{code} --- The Ord is needed for the FiniteMap used in the lookForConstructor --- in SimplEnv. If you declared that lookForConstructor *ignores* --- constructor-applications with LitArg args, then you could get --- rid of this Ord. - -instance Outputable AltCon where - ppr (DataAlt dc) = ppr dc - ppr (LitAlt lit) = ppr lit - ppr DEFAULT = ptext (sLit "__DEFAULT") - -cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering -cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 - -ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool -ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT - -cmpAltCon :: AltCon -> AltCon -> Ordering --- ^ Compares 'AltCon's within a single list of alternatives -cmpAltCon DEFAULT DEFAULT = EQ -cmpAltCon DEFAULT _ = LT - -cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2 -cmpAltCon (DataAlt _) DEFAULT = GT -cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2 -cmpAltCon (LitAlt _) DEFAULT = GT - -cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> - ppr con1 <+> ppr con2 ) - LT -\end{code} - -%************************************************************************ -%* * -\subsection{Useful synonyms} -%* * -%************************************************************************ - -Note [CoreProgram] -~~~~~~~~~~~~~~~~~~ -The top level bindings of a program, a CoreProgram, are represented as -a list of CoreBind - - * Later bindings in the list can refer to earlier ones, but not vice - versa. So this is OK - NonRec { x = 4 } - Rec { p = ...q...x... - ; q = ...p...x } - Rec { f = ...p..x..f.. } - NonRec { g = ..f..q...x.. } - But it would NOT be ok for 'f' to refer to 'g'. - - * The occurrence analyser does strongly-connected component analysis - on each Rec binding, and splits it into a sequence of smaller - bindings where possible. So the program typically starts life as a - single giant Rec, which is then dependency-analysed into smaller - chunks. - -\begin{code} - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.lhs -type CoreProgram = [CoreBind] -- See Note [CoreProgram] - --- | The common case for the type of binders and variables when --- we are manipulating the Core language within GHC -type CoreBndr = Var --- | Expressions where binders are 'CoreBndr's -type CoreExpr = Expr CoreBndr --- | Argument expressions where binders are 'CoreBndr's -type CoreArg = Arg CoreBndr --- | Binding groups where binders are 'CoreBndr's -type CoreBind = Bind CoreBndr --- | Case alternatives where binders are 'CoreBndr's -type CoreAlt = Alt CoreBndr -\end{code} - -%************************************************************************ -%* * -\subsection{Tagging} -%* * -%************************************************************************ - -\begin{code} --- | Binders are /tagged/ with a t -data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" - -type TaggedBind t = Bind (TaggedBndr t) -type TaggedExpr t = Expr (TaggedBndr t) -type TaggedArg t = Arg (TaggedBndr t) -type TaggedAlt t = Alt (TaggedBndr t) - -instance Outputable b => Outputable (TaggedBndr b) where - ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>' - -instance Outputable b => OutputableBndr (TaggedBndr b) where - pprBndr _ b = ppr b -- Simple - pprInfixOcc b = ppr b - pprPrefixOcc b = ppr b - -deTagExpr :: TaggedExpr t -> CoreExpr -deTagExpr (Var v) = Var v -deTagExpr (Lit l) = Lit l -deTagExpr (Type ty) = Type ty -deTagExpr (Coercion co) = Coercion co -deTagExpr (App e1 e2) = App (deTagExpr e1) (deTagExpr e2) -deTagExpr (Lam (TB b _) e) = Lam b (deTagExpr e) -deTagExpr (Let bind body) = Let (deTagBind bind) (deTagExpr body) -deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts) -deTagExpr (Tick t e) = Tick t (deTagExpr e) -deTagExpr (Cast e co) = Cast (deTagExpr e) co - -deTagBind :: TaggedBind t -> CoreBind -deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs) -deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs] - -deTagAlt :: TaggedAlt t -> CoreAlt -deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs) -\end{code} - - -%************************************************************************ -%* * -\subsection{Core-constructing functions with checking} -%* * -%************************************************************************ - -\begin{code} --- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to --- use 'MkCore.mkCoreApps' if possible -mkApps :: Expr b -> [Arg b] -> Expr b --- | Apply a list of type argument expressions to a function expression in a nested fashion -mkTyApps :: Expr b -> [Type] -> Expr b --- | Apply a list of coercion argument expressions to a function expression in a nested fashion -mkCoApps :: Expr b -> [Coercion] -> Expr b --- | Apply a list of type or value variables to a function expression in a nested fashion -mkVarApps :: Expr b -> [Var] -> Expr b --- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to --- use 'MkCore.mkCoreConApps' if possible -mkConApp :: DataCon -> [Arg b] -> Expr b - -mkApps f args = foldl App f args -mkTyApps f args = foldl (\ e a -> App e (Type a)) f args -mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args -mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars -mkConApp con args = mkApps (Var (dataConWorkId con)) args - -mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b -mkConApp2 con tys arg_ids = Var (dataConWorkId con) - `mkApps` map Type tys - `mkApps` map varToCoreExpr arg_ids - - --- | Create a machine integer literal expression of type @Int#@ from an @Integer@. --- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' -mkIntLit :: DynFlags -> Integer -> Expr b --- | Create a machine integer literal expression of type @Int#@ from an @Int@. --- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' -mkIntLitInt :: DynFlags -> Int -> Expr b - -mkIntLit dflags n = Lit (mkMachInt dflags n) -mkIntLitInt dflags n = Lit (mkMachInt dflags (toInteger n)) - --- | Create a machine word literal expression of type @Word#@ from an @Integer@. --- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' -mkWordLit :: DynFlags -> Integer -> Expr b --- | Create a machine word literal expression of type @Word#@ from a @Word@. --- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' -mkWordLitWord :: DynFlags -> Word -> Expr b - -mkWordLit dflags w = Lit (mkMachWord dflags w) -mkWordLitWord dflags w = Lit (mkMachWord dflags (toInteger w)) - -mkWord64LitWord64 :: Word64 -> Expr b -mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w)) - -mkInt64LitInt64 :: Int64 -> Expr b -mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w)) - --- | Create a machine character literal expression of type @Char#@. --- If you want an expression of type @Char@ use 'MkCore.mkCharExpr' -mkCharLit :: Char -> Expr b --- | Create a machine string literal expression of type @Addr#@. --- If you want an expression of type @String@ use 'MkCore.mkStringExpr' -mkStringLit :: String -> Expr b - -mkCharLit c = Lit (mkMachChar c) -mkStringLit s = Lit (mkMachString s) - --- | Create a machine single precision literal expression of type @Float#@ from a @Rational@. --- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' -mkFloatLit :: Rational -> Expr b --- | Create a machine single precision literal expression of type @Float#@ from a @Float@. --- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' -mkFloatLitFloat :: Float -> Expr b - -mkFloatLit f = Lit (mkMachFloat f) -mkFloatLitFloat f = Lit (mkMachFloat (toRational f)) - --- | Create a machine double precision literal expression of type @Double#@ from a @Rational@. --- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' -mkDoubleLit :: Rational -> Expr b --- | Create a machine double precision literal expression of type @Double#@ from a @Double@. --- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' -mkDoubleLitDouble :: Double -> Expr b - -mkDoubleLit d = Lit (mkMachDouble d) -mkDoubleLitDouble d = Lit (mkMachDouble (toRational d)) - --- | Bind all supplied binding groups over an expression in a nested let expression. Assumes --- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if --- possible, which does guarantee the invariant -mkLets :: [Bind b] -> Expr b -> Expr b --- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to --- use 'MkCore.mkCoreLams' if possible -mkLams :: [b] -> Expr b -> Expr b - -mkLams binders body = foldr Lam body binders -mkLets binds body = foldr Let body binds - - --- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", --- this can only be used to bind something in a non-recursive @let@ expression -mkTyBind :: TyVar -> Type -> CoreBind -mkTyBind tv ty = NonRec tv (Type ty) - --- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", --- this can only be used to bind something in a non-recursive @let@ expression -mkCoBind :: CoVar -> Coercion -> CoreBind -mkCoBind cv co = NonRec cv (Coercion co) - --- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately -varToCoreExpr :: CoreBndr -> Expr b -varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) - | isCoVar v = Coercion (mkCoVarCo v) - | otherwise = ASSERT( isId v ) Var v - -varsToCoreExprs :: [CoreBndr] -> [Expr b] -varsToCoreExprs vs = map varToCoreExpr vs -\end{code} - - -%************************************************************************ -%* * -\subsection{Simple access functions} -%* * -%************************************************************************ - -\begin{code} --- | Extract every variable by this group -bindersOf :: Bind b -> [b] --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in coreSyn/CoreLint.lhs -bindersOf (NonRec binder _) = [binder] -bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] - --- | 'bindersOf' applied to a list of binding groups -bindersOfBinds :: [Bind b] -> [b] -bindersOfBinds binds = foldr ((++) . bindersOf) [] binds - -rhssOfBind :: Bind b -> [Expr b] -rhssOfBind (NonRec _ rhs) = [rhs] -rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] - -rhssOfAlts :: [Alt b] -> [Expr b] -rhssOfAlts alts = [e | (_,_,e) <- alts] - --- | Collapse all the bindings in the supplied groups into a single --- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group -flattenBinds :: [Bind b] -> [(b, Expr b)] -flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds -flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds -flattenBinds [] = [] -\end{code} - -\begin{code} --- | We often want to strip off leading lambdas before getting down to --- business. This function is your friend. -collectBinders :: Expr b -> ([b], Expr b) --- | Collect as many type bindings as possible from the front of a nested lambda -collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) --- | Collect as many value bindings as possible from the front of a nested lambda -collectValBinders :: CoreExpr -> ([Id], CoreExpr) --- | Collect type binders from the front of the lambda first, --- then follow up by collecting as many value bindings as possible --- from the resulting stripped expression -collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) - -collectBinders expr - = go [] expr - where - go bs (Lam b e) = go (b:bs) e - go bs e = (reverse bs, e) - -collectTyAndValBinders expr - = (tvs, ids, body) - where - (tvs, body1) = collectTyBinders expr - (ids, body) = collectValBinders body1 - -collectTyBinders expr - = go [] expr - where - go tvs (Lam b e) | isTyVar b = go (b:tvs) e - go tvs e = (reverse tvs, e) - -collectValBinders expr - = go [] expr - where - go ids (Lam b e) | isId b = go (b:ids) e - go ids body = (reverse ids, body) -\end{code} - -\begin{code} --- | Takes a nested application expression and returns the the function --- being applied and the arguments to which it is applied -collectArgs :: Expr b -> (Expr b, [Arg b]) -collectArgs expr - = go expr [] - where - go (App f a) as = go f (a:as) - go e as = (e, as) -\end{code} - -%************************************************************************ -%* * -\subsection{Predicates} -%* * -%************************************************************************ - -At one time we optionally carried type arguments through to runtime. -@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime, -i.e. if type applications are actual lambdas because types are kept around -at runtime. Similarly isRuntimeArg. - -\begin{code} --- | Will this variable exist at runtime? -isRuntimeVar :: Var -> Bool -isRuntimeVar = isId - --- | Will this argument expression exist at runtime? -isRuntimeArg :: CoreExpr -> Bool -isRuntimeArg = isValArg - --- | Returns @True@ for value arguments, false for type args --- NB: coercions are value arguments (zero width, to be sure, --- like State#, but still value args). -isValArg :: Expr b -> Bool -isValArg e = not (isTypeArg e) - --- | Returns @True@ iff the expression is a 'Type' or 'Coercion' --- expression at its top level -isTyCoArg :: Expr b -> Bool -isTyCoArg (Type {}) = True -isTyCoArg (Coercion {}) = True -isTyCoArg _ = False - --- | Returns @True@ iff the expression is a 'Type' expression at its --- top level. Note this does NOT include 'Coercion's. -isTypeArg :: Expr b -> Bool -isTypeArg (Type {}) = True -isTypeArg _ = False - --- | The number of binders that bind values rather than types -valBndrCount :: [CoreBndr] -> Int -valBndrCount = count isId - --- | The number of argument expressions that are values rather than types at their top level -valArgCount :: [Arg b] -> Int -valArgCount = count isValArg -\end{code} - - -%************************************************************************ -%* * -\subsection{Seq stuff} -%* * -%************************************************************************ - -\begin{code} -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 - -seqBndr :: CoreBndr -> () -seqBndr b = b `seq` () - -seqBndrs :: [CoreBndr] -> () -seqBndrs [] = () -seqBndrs (b:bs) = seqBndr b `seq` seqBndrs 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 - -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 -\end{code} - -%************************************************************************ -%* * -\subsection{Annotated core} -%* * -%************************************************************************ - -\begin{code} --- | Annotated core: allows annotation at every node in the tree -type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) - --- | A clone of the 'Expr' type but allowing annotation at every tree node -data AnnExpr' bndr annot - = AnnVar Id - | AnnLit Literal - | AnnLam bndr (AnnExpr bndr annot) - | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) - | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] - | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) - | AnnCast (AnnExpr bndr annot) (annot, Coercion) - -- Put an annotation on the (root of) the coercion - | AnnTick (Tickish Id) (AnnExpr bndr annot) - | AnnType Type - | AnnCoercion Coercion - --- | A clone of the 'Alt' type but allowing annotation at every tree node -type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) - --- | A clone of the 'Bind' type but allowing annotation at every tree node -data AnnBind bndr annot - = AnnNonRec bndr (AnnExpr bndr annot) - | AnnRec [(bndr, AnnExpr bndr annot)] -\end{code} - -\begin{code} --- | Takes a nested application expression and returns the the function --- being applied and the arguments to which it is applied -collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) -collectAnnArgs expr - = go expr [] - where - go (_, AnnApp f a) as = go f (a:as) - go e as = (e, as) -\end{code} - -\begin{code} -deAnnotate :: AnnExpr bndr annot -> Expr bndr -deAnnotate (_, e) = deAnnotate' e - -deAnnotate' :: AnnExpr' bndr annot -> Expr bndr -deAnnotate' (AnnType t) = Type t -deAnnotate' (AnnCoercion co) = Coercion co -deAnnotate' (AnnVar v) = Var v -deAnnotate' (AnnLit lit) = Lit lit -deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) -deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) -deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co -deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body) - -deAnnotate' (AnnLet bind body) - = Let (deAnnBind bind) (deAnnotate body) - where - deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) - deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] - -deAnnotate' (AnnCase scrut v t alts) - = Case (deAnnotate scrut) v t (map deAnnAlt alts) - -deAnnAlt :: AnnAlt bndr annot -> Alt bndr -deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) -\end{code} - -\begin{code} --- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr' -collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) -collectAnnBndrs e - = collect [] e - where - collect bs (_, AnnLam b body) = collect (b:bs) body - collect bs body = (reverse bs, body) -\end{code} diff --git a/compiler/coreSyn/CoreTidy.hs b/compiler/coreSyn/CoreTidy.hs new file mode 100644 index 0000000000..7f09c68ca2 --- /dev/null +++ b/compiler/coreSyn/CoreTidy.hs @@ -0,0 +1,272 @@ +{- +(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 TidyPgm. +-} + +{-# LANGUAGE CPP #-} +module CoreTidy ( + tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding + ) where + +#include "HsVersions.h" + +import CoreSyn +import CoreArity +import Id +import IdInfo +import Type( tidyType, tidyTyVarBndr ) +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,rhs) =: \ (env', bndr') -> + (env', NonRec bndr' (tidyExpr env' rhs)) + +tidyBind env (Rec prs) + = let + (env', bndrs') = mapAccumL (tidyLetBndr env') env prs + in + map (tidyExpr env') (map snd prs) =: \ 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 b env') alts) + +tidyExpr env (Lam b e) + = tidyBndr env b =: \ (env', b) -> + Lam b (tidyExpr env' e) + +------------ Case alternatives -------------- +tidyAlt :: CoreBndr -> TidyEnv -> CoreAlt -> CoreAlt +tidyAlt _case_bndr 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 + | isTyVar var = tidyTyVarBndr env var + | otherwise = tidyIdBndr env var + +tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +tidyBndrs env vars = mapAccumL tidyBndr env vars + +-- Non-top-level variables +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 | isEvaldUnfolding old_unf = evaldUnfolding + | otherwise = noUnfolding + -- See Note [Preserve evaluatedness] + in + ((tidy_env', var_env'), id') + } + +tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings + -> TidyEnv -- The one to extend + -> (Id, CoreExpr) -> (TidyEnv, Var) +-- 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,rhs) + = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + 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] + -- 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. + -- + -- Similarly arity info for eta expansion in CorePrep + -- + -- Set inline-prag info so that we preseve it across + -- separate compilation boundaries + old_info = idInfo id + new_info = vanillaIdInfo + `setOccInfo` occInfo old_info + `setArityInfo` exprArity rhs + `setStrictnessInfo` strictnessInfo old_info + `setDemandInfo` demandInfo old_info + `setInlinePragInfo` inlinePragInfo old_info + `setUnfoldingInfo` new_unf + + new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf + | otherwise = noUnfolding + old_unf = unfoldingInfo old_info + 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 + = unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo + | otherwise + = unf_from_rhs +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 of the +optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we +must preserve this info in inlinings. + +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/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs deleted file mode 100644 index 810a71ca6c..0000000000 --- a/compiler/coreSyn/CoreTidy.lhs +++ /dev/null @@ -1,276 +0,0 @@ -% -% (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 TidyPgm. - -\begin{code} -{-# LANGUAGE CPP #-} -module CoreTidy ( - tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding - ) where - -#include "HsVersions.h" - -import CoreSyn -import CoreArity -import Id -import IdInfo -import Type( tidyType, tidyTyVarBndr ) -import Coercion( tidyCo ) -import Var -import VarEnv -import UniqFM -import Name hiding (tidyNameOcc) -import SrcLoc -import Maybes -import Data.List -\end{code} - - -%************************************************************************ -%* * -\subsection{Tidying expressions, rules} -%* * -%************************************************************************ - -\begin{code} -tidyBind :: TidyEnv - -> CoreBind - -> (TidyEnv, CoreBind) - -tidyBind env (NonRec bndr rhs) - = tidyLetBndr env env (bndr,rhs) =: \ (env', bndr') -> - (env', NonRec bndr' (tidyExpr env' rhs)) - -tidyBind env (Rec prs) - = let - (env', bndrs') = mapAccumL (tidyLetBndr env') env prs - in - map (tidyExpr env') (map snd prs) =: \ 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 b env') alts) - -tidyExpr env (Lam b e) - = tidyBndr env b =: \ (env', b) -> - Lam b (tidyExpr env' e) - ------------- Case alternatives -------------- -tidyAlt :: CoreBndr -> TidyEnv -> CoreAlt -> CoreAlt -tidyAlt _case_bndr 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 } -\end{code} - - -%************************************************************************ -%* * -\subsection{Tidying non-top-level binders} -%* * -%************************************************************************ - -\begin{code} -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 - | isTyVar var = tidyTyVarBndr env var - | otherwise = tidyIdBndr env var - -tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) -tidyBndrs env vars = mapAccumL tidyBndr env vars - --- Non-top-level variables -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 | isEvaldUnfolding old_unf = evaldUnfolding - | otherwise = noUnfolding - -- See Note [Preserve evaluatedness] - in - ((tidy_env', var_env'), id') - } - -tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings - -> TidyEnv -- The one to extend - -> (Id, CoreExpr) -> (TidyEnv, Var) --- 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,rhs) - = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> - let - 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] - -- 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. - -- - -- Similarly arity info for eta expansion in CorePrep - -- - -- Set inline-prag info so that we preseve it across - -- separate compilation boundaries - old_info = idInfo id - new_info = vanillaIdInfo - `setOccInfo` occInfo old_info - `setArityInfo` exprArity rhs - `setStrictnessInfo` strictnessInfo old_info - `setDemandInfo` demandInfo old_info - `setInlinePragInfo` inlinePragInfo old_info - `setUnfoldingInfo` new_unf - - new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf - | otherwise = noUnfolding - old_unf = unfoldingInfo old_info - 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 - = unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo - | otherwise - = unf_from_rhs -tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon -\end{code} - -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 of the -optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we -must preserve this info in inlinings. - -This applies to lambda binders only, hence it is stored in IfaceLamBndr. - - -\begin{code} -(=:) :: a -> (a -> b) -> b -m =: k = m `seq` k m -\end{code} diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs new file mode 100644 index 0000000000..dc9f95e73a --- /dev/null +++ b/compiler/coreSyn/CoreUnfold.hs @@ -0,0 +1,1432 @@ +{- +(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 #-} + +module CoreUnfold ( + Unfolding, UnfoldingGuidance, -- Abstract types + + noUnfolding, mkImplicitUnfolding, + mkUnfolding, mkCoreUnfolding, + mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding, + mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule, + mkCompulsoryUnfolding, mkDFunUnfolding, + specUnfolding, + + interestingArg, ArgSummary(..), + + couldBeSmallEnoughToInline, inlineBoringOk, + certainlyWillInline, smallEnoughToInline, + + callSiteInline, CallCtxt(..), + + -- Reexport from CoreSubst (it only live there so it can be used + -- by the Very Simple Optimiser) + exprIsConApp_maybe, exprIsLiteral_maybe + ) where + +#include "HsVersions.h" + +import DynFlags +import CoreSyn +import PprCore () -- Instances +import OccurAnal ( occurAnalyseExpr ) +import CoreSubst hiding( substTy ) +import CoreArity ( manifestArity, exprBotStrictness_maybe ) +import CoreUtils +import Id +import DataCon +import Literal +import PrimOp +import IdInfo +import BasicTypes ( Arity ) +import Type +import PrelNames +import TysPrim ( realWorldStatePrimTy ) +import Bag +import Util +import FastTypes +import FastString +import Outputable +import ForeignCall + +import qualified Data.ByteString as BS +import Data.Maybe + +{- +************************************************************************ +* * +\subsection{Making unfoldings} +* * +************************************************************************ +-} + +mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding +mkTopUnfolding dflags = mkUnfolding dflags InlineRhs True {- Top level -} + +mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding +-- For implicit Ids, do a tiny bit of optimising first +mkImplicitUnfolding dflags expr + = mkTopUnfolding dflags False (simpleOptExpr 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 = mkUnfolding dflags InlineRhs False False + +mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding +mkDFunUnfolding bndrs con ops + = DFunUnfolding { df_bndrs = bndrs + , df_con = con + , df_args = map occurAnalyseExpr ops } + -- See Note [Occurrrence analysis of unfoldings] + +mkWwInlineRule :: CoreExpr -> Arity -> Unfolding +mkWwInlineRule expr arity + = mkCoreUnfolding InlineStable True + (simpleOptExpr 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 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 (work_fn tmpl) + guidance = calcUnfoldingGuidance dflags new_tmpl + +mkWorkerUnfolding _ _ _ = noUnfolding + +mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding +mkInlineUnfolding mb_arity expr + = mkCoreUnfolding InlineStable + True -- Note [Top-level flag on inline rules] + expr' guide + where + expr' = simpleOptExpr expr + guide = case mb_arity of + Nothing -> UnfWhen { ug_arity = manifestArity expr' + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boring_ok } + Just arity -> UnfWhen { ug_arity = arity + , ug_unsat_ok = needSaturated + , ug_boring_ok = boring_ok } + boring_ok = inlineBoringOk expr' + +mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding +mkInlinableUnfolding dflags expr + = mkUnfolding dflags InlineStable True is_bot expr' + where + expr' = simpleOptExpr expr + is_bot = isJust (exprBotStrictness_maybe expr') + +specUnfolding :: DynFlags -> Subst -> [Var] -> [CoreExpr] -> Unfolding -> Unfolding +-- See Note [Specialising unfoldings] +specUnfolding _ subst new_bndrs spec_args + df@(DFunUnfolding { df_bndrs = bndrs, df_con = con , df_args = args }) + = ASSERT2( length bndrs >= length spec_args, ppr df $$ ppr spec_args $$ ppr new_bndrs ) + mkDFunUnfolding (new_bndrs ++ extra_bndrs) con + (map (substExpr spec_doc subst2) args) + where + subst1 = extendSubstList subst (bndrs `zip` spec_args) + (subst2, extra_bndrs) = substBndrs subst1 (dropList spec_args bndrs) + +specUnfolding _dflags subst new_bndrs spec_args + (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 - count isValArg spec_args + + count isId new_bndrs + , ug_unsat_ok = unsat_ok + , ug_boring_ok = boring_ok } + new_tmpl = simpleOptExpr $ mkLams new_bndrs $ + mkApps (substExpr spec_doc subst tmpl) spec_args + -- The beta-redexes created here will be simplified + -- away by simplOptExpr in mkUnfolding + + in mkCoreUnfolding src top_lvl new_tmpl guidance + +specUnfolding _ _ _ _ _ = noUnfolding + +spec_doc :: SDoc +spec_doc = ptext (sLit "specUnfolding") + +{- +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 = + {- INLINEABLE f #-} + Now if we specialise f, should the specialised version still have + an INLINEABLE pragma? If it does, we'll capture a specialised copy + of as its unfolding, and that probaby won't inline. But + if we don't, the specialised version of 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 INLINEABLE thing isn't much help, because + the specialised function (probaby) 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 INLINEABLE), we discard it +-} + +mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr + -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it +mkCoreUnfolding src top_lvl expr guidance + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + -- See Note [Occurrrence 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 -> Bool -> CoreExpr + -> Unfolding +-- Calculates unfolding guidance +-- Occurrence-analyses the expression before capturing it +mkUnfolding dflags src top_lvl is_bottoming expr + | top_lvl && is_bottoming + , not (exprIsTrivial expr) + = NoUnfolding -- See Note [Do not inline top-level bottoming functions] + | otherwise + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + -- See Note [Occurrrence analysis of unfoldings] + uf_src = src, + uf_is_top = 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 + guidance = calcUnfoldingGuidance dflags expr + -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr 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 Trac #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 acutally are. + +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 + 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 + -> CoreExpr -- Expression to look at + -> UnfoldingGuidance +calcUnfoldingGuidance dflags expr + = case sizeExpr dflags (iUnbox bOMB_OUT_SIZE) val_bndrs body of + TooBig -> UnfNever + SizeIs size cased_bndrs scrut_discount + | uncondInline expr n_val_bndrs (iBox size) + -> UnfWhen { ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boringCxtOk + , ug_arity = n_val_bndrs } -- Note [INLINE for small functions] + | otherwise + -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs + , ug_size = iBox size + , ug_res = iBox 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 = foldlBag 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 unversally 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] +-} + +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 + -> FastInt -- 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 `addSizeNSD` + size_up body `addSizeN` + (if isUnLiftedType (idType binder) then 0 else 10) + -- For the allocation + -- If the binder has an unlifted type there is no allocation + + size_up (Let (Rec pairs) body) + = foldr (addSizeNSD . size_up . snd) + (size_up body `addSizeN` (10 * length pairs)) -- (length pairs) for the allocation + pairs + + size_up (Case (Var v) _ _ alts) + | v `elem` top_args -- We are scrutinising an argument variable + = alts_size (foldr addAltSize sizeZero alt_sizes) + (foldr maxSize sizeZero 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 + 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, iBox (_ILIT(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 + + size_up (Case e _ _ alts) = size_up e `addSizeNSD` + foldr (addAltSize . size_up_alt) case_size alts + where + case_size + | is_inline_scrut e, not (lengthExceeds 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 "not (lengthExceeds 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_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 other args voids = size_up other `addSizeN` (length args - voids) + + ------------ + size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize + size_up_call fun val_args voids + = case idDetails fun of + FCallId _ -> sizeN (10 * (1 + length val_args)) + 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) + -- + -- IMPORATANT: *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.errrnoToIOError + + ------------ + -- 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 +# iUnbox 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 _ = False + +-- | Finds a nominal size of a string literal. +litSize :: Literal -> Int +-- Used by CoreUnfold.sizeExpr +litSize (LitInteger {}) = 100 -- Note [Size of literal integers] +litSize (MachStr 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 (iUnbox size) arg_discount (_ILIT(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 + +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 (iUnbox size) arg_discount (iUnbox res_discount) + where + some_val_args = n_val_args > 0 + + size | some_val_args = 10 * (1 + n_val_args - voids) + | otherwise = 0 + -- The 1+ is for the function itself + -- Add 1 for each non-trivial arg; + -- the allocation cost, as in let(rec) + + -- 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 + +conSize :: DataCon -> Int -> ExprSize +conSize dc n_val_args + | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10)) -- Like variables + +-- See Note [Unboxed tuple size and result discount] + | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox (10 * (1 + n_val_args))) + +-- See Note [Constructor size and result discount] + | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (1 + n_val_args))) + +{- +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 fuction with many many case branches, each finishing with +a constructor, can have an arbitrarily large discount. This led to +terrible code bloat: see Trac #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 Trac #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 +Trac #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 aribitrary 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 (_ILIT(0)) emptyBag (_ILIT(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 becuause 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 (_ILIT(0)) emptyBag (_ILIT(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 (iUnbox (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 + + +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 +-} + +data ExprSize = TooBig + | SizeIs FastInt -- Size found + !(Bag (Id,Int)) -- Arguments cased herein, and discount for each such + FastInt -- Size to subtract if result is scrutinised + -- by a case expression + +instance Outputable ExprSize where + ppr TooBig = ptext (sLit "TooBig") + ppr (SizeIs a _ c) = brackets (int (iBox a) <+> int (iBox 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 :: FastInt -> FastInt -> Bag (Id, Int) -> FastInt -> 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 (_ILIT(0)) emptyBag (_ILIT(0)) +sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT(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 (iUnbox 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 -> Unfolding -> 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 unf@(CoreUnfolding { uf_guidance = guidance, uf_tmpl = expr }) + = case guidance of + UnfNever -> Nothing + UnfWhen {} -> Just (unf { uf_src = InlineStable }) + + -- 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 whyy. + UnfIfGoodArgs { ug_size = size, ug_args = args } + | not (null args) -- See Note [certainlyWillInline: be careful of thunks] + , let arity = length args + , size - (10 * (arity + 1)) <= ufUseThreshold dflags + -> Just (unf { uf_src = InlineStable + , uf_guidance = UnfWhen { ug_arity = 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 + + _ -> Nothing + +certainlyWillInline _ unf@(DFunUnfolding {}) + = Just unf + +certainlyWillInline _ _ + = 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 Trac #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. + + +************************************************************************ +* * +\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 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 + +instance Outputable ArgSummary where + ppr TrivArg = ptext (sLit "TrivArg") + ppr NonTrivArg = ptext (sLit "NonTrivArg") + ppr ValueArg = ptext (sLit "ValueArg") + +data CallCtxt + = BoringCtxt + | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets] + | DiscArgCtxt -- Argument of a fuction 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 = ptext (sLit "CaseCtxt") + ppr ValAppCtxt = ptext (sLit "ValAppCtxt") + ppr BoringCtxt = ptext (sLit "BoringCtxt") + ppr RhsCtxt = ptext (sLit "RhsCtxt") + ppr DiscArgCtxt = ptext (sLit "DiscArgCtxt") + ppr RuleArgCtxt = ptext (sLit "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_top = is_top + , 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_top + is_wf is_exp guidance + | otherwise -> traceInline dflags "Inactive unfolding:" (ppr id) Nothing + NoUnfolding -> Nothing + OtherCon {} -> Nothing + DFunUnfolding {} -> Nothing -- Never unfold a DFun + +traceInline :: DynFlags -> String -> SDoc -> a -> a +traceInline dflags str doc result + | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags + = pprTrace str doc result + | otherwise + = result + +tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt + -> CoreExpr -> Bool -> Bool -> Bool -> UnfoldingGuidance + -> Maybe CoreExpr +tryUnfolding dflags id lone_variable + arg_infos cont_info unf_template is_top + is_wf is_exp guidance + = case guidance of + UnfNever -> traceInline dflags str (ptext (sLit "UnfNever")) Nothing + + UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + | enough_args && (boring_ok || some_benefit) + -- See Note [INLINE for small functions (3)] + -> traceInline dflags str (mk_doc some_benefit empty True) (Just unf_template) + | otherwise + -> traceInline dflags 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 } + | is_wf && some_benefit && small_enough + -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template) + | otherwise + -> traceInline dflags 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_wf) -- Note [Lone variables] + ValAppCtxt -> True -- Note [Cast then apply] + RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts] + DiscArgCtxt -> uf_arity > 0 -- + RhsCtxt -> uf_arity > 0 -- + _ -> not is_top && uf_arity > 0 -- Note [Nested functions] + -- Note [Inlining in ArgCtxt] + +{- +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] +~~~~~~~~~~~~~~~~~~~~~~~ +If a function has a nested defn we also record some-benefit, on the +grounds that we are often able to eliminate the binding, and hence the +allocation, for the function altogether; this is good for join points. +But this only makes sense for *functions*; inlining a constructor +doesn't help allocation unless the result is scrutinised. UNLESS the +constructor occurs just once, albeit possibly in multiple case +branches. Then inlining it doesn't increase allocation, but it does +increase the chance that the constructor won't be allocated at all in +the branches that don't use it. + +Note [Cast then apply] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + myIndex = __inline_me ( (/\a. ) |> 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 varaints, 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. is 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 the +context can ``see'' the unfolding of the variable (e.g. case or a +RULE) so there's no gain. If the thing is bound to a value. + +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 +scrutines 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 aovid inlining large functions that return + -- constructors into contexts that are simply "interesting" + +{- +************************************************************************ +* * + Interesting arguments +* * +************************************************************************ + +Note [Interesting arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An argument is interesting if it deserves a discount for unfoldings +with a discount in that argument position. The idea is to avoid +unfolding a function that is applied only to variables that have no +unfolding (i.e. they are probably lambda bound): f x y z There is +little point in inlining f here. + +Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But +we must look through lets, eg (let x = e in C a b), because the let will +float, exposing the value, if we inline. That makes it different to +exprIsHNF. + +Before 2009 we said it was interesting if the argument had *any* structure +at all; i.e. (hasSomeUnfolding v). But does too much inlining; see Trac #3016. + +But we don't regard (f x y) as interesting, unless f is unsaturated. +If it's saturated and f hasn't inlined, then it's probably not going +to now! + +Note [Conlike is interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f d = ...((*) d x y)... + ... f (df d')... +where df is con-like. Then we'd really like to inline 'f' so that the +rule for (*) (df d) can fire. To do this + a) we give a discount for being an argument of a class-op (eg (*) d) + b) we say that a con-like argument (eg (df d)) is interesting +-} + +data ArgSummary = TrivArg -- Nothing interesting + | NonTrivArg -- Arg has structure + | ValueArg -- Arg is a con-app or PAP + -- ..or con-like. Note [Conlike is interesting] + +interestingArg :: CoreExpr -> ArgSummary +-- See Note [Interesting arguments] +interestingArg e = go e 0 + where + -- n is # value args to which the expression is applied + go (Lit {}) _ = ValueArg + go (Var v) n + | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that + -- data constructors here + | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding + | n > 0 = NonTrivArg -- Saturated or unknown call + | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding + -- See Note [Conlike is interesting] + | otherwise = TrivArg -- n==0, no useful unfolding + where + conlike_unfolding = isConLikeUnfolding (idUnfolding v) + + go (Type _) _ = TrivArg + go (Coercion _) _ = TrivArg + go (App fn (Type _)) n = go fn n + go (App fn (Coercion _)) n = go fn n + go (App fn _) n = go fn (n+1) + go (Tick _ a) n = go a n + go (Cast e _) n = go e n + go (Lam v e) n + | isTyVar v = go e n + | n>0 = go e (n-1) + | otherwise = ValueArg + go (Let _ e) n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg } + go (Case {}) _ = NonTrivArg + +nonTriv :: ArgSummary -> Bool +nonTriv TrivArg = False +nonTriv _ = True diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs deleted file mode 100644 index fd485ae2b7..0000000000 --- a/compiler/coreSyn/CoreUnfold.lhs +++ /dev/null @@ -1,1442 +0,0 @@ -% -% (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. - -\begin{code} -{-# LANGUAGE CPP #-} - -module CoreUnfold ( - Unfolding, UnfoldingGuidance, -- Abstract types - - noUnfolding, mkImplicitUnfolding, - mkUnfolding, mkCoreUnfolding, - mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding, - mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule, - mkCompulsoryUnfolding, mkDFunUnfolding, - specUnfolding, - - interestingArg, ArgSummary(..), - - couldBeSmallEnoughToInline, inlineBoringOk, - certainlyWillInline, smallEnoughToInline, - - callSiteInline, CallCtxt(..), - - -- Reexport from CoreSubst (it only live there so it can be used - -- by the Very Simple Optimiser) - exprIsConApp_maybe, exprIsLiteral_maybe - ) where - -#include "HsVersions.h" - -import DynFlags -import CoreSyn -import PprCore () -- Instances -import OccurAnal ( occurAnalyseExpr ) -import CoreSubst hiding( substTy ) -import CoreArity ( manifestArity, exprBotStrictness_maybe ) -import CoreUtils -import Id -import DataCon -import Literal -import PrimOp -import IdInfo -import BasicTypes ( Arity ) -import Type -import PrelNames -import TysPrim ( realWorldStatePrimTy ) -import Bag -import Util -import FastTypes -import FastString -import Outputable -import ForeignCall - -import qualified Data.ByteString as BS -import Data.Maybe -\end{code} - - -%************************************************************************ -%* * -\subsection{Making unfoldings} -%* * -%************************************************************************ - -\begin{code} -mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding -mkTopUnfolding dflags = mkUnfolding dflags InlineRhs True {- Top level -} - -mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding --- For implicit Ids, do a tiny bit of optimising first -mkImplicitUnfolding dflags expr - = mkTopUnfolding dflags False (simpleOptExpr 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 = mkUnfolding dflags InlineRhs False False - -mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding -mkDFunUnfolding bndrs con ops - = DFunUnfolding { df_bndrs = bndrs - , df_con = con - , df_args = map occurAnalyseExpr ops } - -- See Note [Occurrrence analysis of unfoldings] - -mkWwInlineRule :: CoreExpr -> Arity -> Unfolding -mkWwInlineRule expr arity - = mkCoreUnfolding InlineStable True - (simpleOptExpr 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 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 (work_fn tmpl) - guidance = calcUnfoldingGuidance dflags new_tmpl - -mkWorkerUnfolding _ _ _ = noUnfolding - -mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding -mkInlineUnfolding mb_arity expr - = mkCoreUnfolding InlineStable - True -- Note [Top-level flag on inline rules] - expr' guide - where - expr' = simpleOptExpr expr - guide = case mb_arity of - Nothing -> UnfWhen { ug_arity = manifestArity expr' - , ug_unsat_ok = unSaturatedOk - , ug_boring_ok = boring_ok } - Just arity -> UnfWhen { ug_arity = arity - , ug_unsat_ok = needSaturated - , ug_boring_ok = boring_ok } - boring_ok = inlineBoringOk expr' - -mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding -mkInlinableUnfolding dflags expr - = mkUnfolding dflags InlineStable True is_bot expr' - where - expr' = simpleOptExpr expr - is_bot = isJust (exprBotStrictness_maybe expr') - -specUnfolding :: DynFlags -> Subst -> [Var] -> [CoreExpr] -> Unfolding -> Unfolding --- See Note [Specialising unfoldings] -specUnfolding _ subst new_bndrs spec_args - df@(DFunUnfolding { df_bndrs = bndrs, df_con = con , df_args = args }) - = ASSERT2( length bndrs >= length spec_args, ppr df $$ ppr spec_args $$ ppr new_bndrs ) - mkDFunUnfolding (new_bndrs ++ extra_bndrs) con - (map (substExpr spec_doc subst2) args) - where - subst1 = extendSubstList subst (bndrs `zip` spec_args) - (subst2, extra_bndrs) = substBndrs subst1 (dropList spec_args bndrs) - -specUnfolding _dflags subst new_bndrs spec_args - (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 - count isValArg spec_args - + count isId new_bndrs - , ug_unsat_ok = unsat_ok - , ug_boring_ok = boring_ok } - new_tmpl = simpleOptExpr $ mkLams new_bndrs $ - mkApps (substExpr spec_doc subst tmpl) spec_args - -- The beta-redexes created here will be simplified - -- away by simplOptExpr in mkUnfolding - - in mkCoreUnfolding src top_lvl new_tmpl guidance - -specUnfolding _ _ _ _ _ = noUnfolding - -spec_doc :: SDoc -spec_doc = ptext (sLit "specUnfolding") -\end{code} - -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 = - {- INLINEABLE f #-} - Now if we specialise f, should the specialised version still have - an INLINEABLE pragma? If it does, we'll capture a specialised copy - of as its unfolding, and that probaby won't inline. But - if we don't, the specialised version of 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 INLINEABLE thing isn't much help, because - the specialised function (probaby) 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 INLINEABLE), we discard it - - -\begin{code} -mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr - -> UnfoldingGuidance -> Unfolding --- Occurrence-analyses the expression before capturing it -mkCoreUnfolding src top_lvl expr guidance - = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, - -- See Note [Occurrrence 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 -> Bool -> CoreExpr - -> Unfolding --- Calculates unfolding guidance --- Occurrence-analyses the expression before capturing it -mkUnfolding dflags src top_lvl is_bottoming expr - | top_lvl && is_bottoming - , not (exprIsTrivial expr) - = NoUnfolding -- See Note [Do not inline top-level bottoming functions] - | otherwise - = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, - -- See Note [Occurrrence analysis of unfoldings] - uf_src = src, - uf_is_top = 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 - guidance = calcUnfoldingGuidance dflags expr - -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))! - -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] -\end{code} - -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 Trac #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 acutally are. - -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} -%* * -%************************************************************************ - -\begin{code} -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 - 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 - -> CoreExpr -- Expression to look at - -> UnfoldingGuidance -calcUnfoldingGuidance dflags expr - = case sizeExpr dflags (iUnbox bOMB_OUT_SIZE) val_bndrs body of - TooBig -> UnfNever - SizeIs size cased_bndrs scrut_discount - | uncondInline expr n_val_bndrs (iBox size) - -> UnfWhen { ug_unsat_ok = unSaturatedOk - , ug_boring_ok = boringCxtOk - , ug_arity = n_val_bndrs } -- Note [INLINE for small functions] - | otherwise - -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs - , ug_size = iBox size - , ug_res = iBox 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 = foldlBag 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] -\end{code} - -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 unversally 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] - -\begin{code} -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) -\end{code} - - -\begin{code} -sizeExpr :: DynFlags - -> FastInt -- 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 `addSizeNSD` - size_up body `addSizeN` - (if isUnLiftedType (idType binder) then 0 else 10) - -- For the allocation - -- If the binder has an unlifted type there is no allocation - - size_up (Let (Rec pairs) body) - = foldr (addSizeNSD . size_up . snd) - (size_up body `addSizeN` (10 * length pairs)) -- (length pairs) for the allocation - pairs - - size_up (Case (Var v) _ _ alts) - | v `elem` top_args -- We are scrutinising an argument variable - = alts_size (foldr addAltSize sizeZero alt_sizes) - (foldr maxSize sizeZero 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 - 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, iBox (_ILIT(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 - - size_up (Case e _ _ alts) = size_up e `addSizeNSD` - foldr (addAltSize . size_up_alt) case_size alts - where - case_size - | is_inline_scrut e, not (lengthExceeds 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 "not (lengthExceeds 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_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 other args voids = size_up other `addSizeN` (length args - voids) - - ------------ - size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize - size_up_call fun val_args voids - = case idDetails fun of - FCallId _ -> sizeN (10 * (1 + length val_args)) - 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) - -- - -- IMPORATANT: *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.errrnoToIOError - - ------------ - -- 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 +# iUnbox 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 _ = False -\end{code} - - -\begin{code} --- | Finds a nominal size of a string literal. -litSize :: Literal -> Int --- Used by CoreUnfold.sizeExpr -litSize (LitInteger {}) = 100 -- Note [Size of literal integers] -litSize (MachStr 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 (iUnbox size) arg_discount (_ILIT(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 - -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 (iUnbox size) arg_discount (iUnbox res_discount) - where - some_val_args = n_val_args > 0 - - size | some_val_args = 10 * (1 + n_val_args - voids) - | otherwise = 0 - -- The 1+ is for the function itself - -- Add 1 for each non-trivial arg; - -- the allocation cost, as in let(rec) - - -- 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 - -conSize :: DataCon -> Int -> ExprSize -conSize dc n_val_args - | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10)) -- Like variables - --- See Note [Unboxed tuple size and result discount] - | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox (10 * (1 + n_val_args))) - --- See Note [Constructor size and result discount] - | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (1 + n_val_args))) -\end{code} - -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 fuction with many many case branches, each finishing with -a constructor, can have an arbitrarily large discount. This led to -terrible code bloat: see Trac #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 Trac #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 -Trac #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 aribitrary 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. - -\begin{code} -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 (_ILIT(0)) emptyBag (_ILIT(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 becuause 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 (_ILIT(0)) emptyBag (_ILIT(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 (iUnbox (ufFunAppDiscount dflags)) -lamScrutDiscount _ TooBig = TooBig -\end{code} - -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 - - -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 - -\begin{code} -data ExprSize = TooBig - | SizeIs FastInt -- Size found - !(Bag (Id,Int)) -- Arguments cased herein, and discount for each such - FastInt -- Size to subtract if result is scrutinised - -- by a case expression - -instance Outputable ExprSize where - ppr TooBig = ptext (sLit "TooBig") - ppr (SizeIs a _ c) = brackets (int (iBox a) <+> int (iBox 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 :: FastInt -> FastInt -> Bag (Id, Int) -> FastInt -> 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 (_ILIT(0)) emptyBag (_ILIT(0)) -sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT(0)) -\end{code} - - -%************************************************************************ -%* * -\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. - -\begin{code} -couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool -couldBeSmallEnoughToInline dflags threshold rhs - = case sizeExpr dflags (iUnbox 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 -> Unfolding -> 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 unf@(CoreUnfolding { uf_guidance = guidance, uf_tmpl = expr }) - = case guidance of - UnfNever -> Nothing - UnfWhen {} -> Just (unf { uf_src = InlineStable }) - - -- 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 whyy. - UnfIfGoodArgs { ug_size = size, ug_args = args } - | not (null args) -- See Note [certainlyWillInline: be careful of thunks] - , let arity = length args - , size - (10 * (arity + 1)) <= ufUseThreshold dflags - -> Just (unf { uf_src = InlineStable - , uf_guidance = UnfWhen { ug_arity = 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 - - _ -> Nothing - -certainlyWillInline _ unf@(DFunUnfolding {}) - = Just unf - -certainlyWillInline _ _ - = Nothing -\end{code} - -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 Trac #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. - - -%************************************************************************ -%* * -\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 - -\begin{code} -callSiteInline :: DynFlags - -> Id -- The Id - -> Bool -- True <=> unfolding is active - -> Bool -- True if there are 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 - -instance Outputable ArgSummary where - ppr TrivArg = ptext (sLit "TrivArg") - ppr NonTrivArg = ptext (sLit "NonTrivArg") - ppr ValueArg = ptext (sLit "ValueArg") - -data CallCtxt - = BoringCtxt - | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets] - | DiscArgCtxt -- Argument of a fuction 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 = ptext (sLit "CaseCtxt") - ppr ValAppCtxt = ptext (sLit "ValAppCtxt") - ppr BoringCtxt = ptext (sLit "BoringCtxt") - ppr RhsCtxt = ptext (sLit "RhsCtxt") - ppr DiscArgCtxt = ptext (sLit "DiscArgCtxt") - ppr RuleArgCtxt = ptext (sLit "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_top = is_top - , 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_top - is_wf is_exp guidance - | otherwise -> traceInline dflags "Inactive unfolding:" (ppr id) Nothing - NoUnfolding -> Nothing - OtherCon {} -> Nothing - DFunUnfolding {} -> Nothing -- Never unfold a DFun - -traceInline :: DynFlags -> String -> SDoc -> a -> a -traceInline dflags str doc result - | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags - = pprTrace str doc result - | otherwise - = result - -tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt - -> CoreExpr -> Bool -> Bool -> Bool -> UnfoldingGuidance - -> Maybe CoreExpr -tryUnfolding dflags id lone_variable - arg_infos cont_info unf_template is_top - is_wf is_exp guidance - = case guidance of - UnfNever -> traceInline dflags str (ptext (sLit "UnfNever")) Nothing - - UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } - | enough_args && (boring_ok || some_benefit) - -- See Note [INLINE for small functions (3)] - -> traceInline dflags str (mk_doc some_benefit empty True) (Just unf_template) - | otherwise - -> traceInline dflags 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 } - | is_wf && some_benefit && small_enough - -> traceInline dflags str (mk_doc some_benefit extra_doc True) (Just unf_template) - | otherwise - -> traceInline dflags 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_wf) -- Note [Lone variables] - ValAppCtxt -> True -- Note [Cast then apply] - RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts] - DiscArgCtxt -> uf_arity > 0 -- - RhsCtxt -> uf_arity > 0 -- - _ -> not is_top && uf_arity > 0 -- Note [Nested functions] - -- Note [Inlining in ArgCtxt] -\end{code} - -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] -~~~~~~~~~~~~~~~~~~~~~~~ -If a function has a nested defn we also record some-benefit, on the -grounds that we are often able to eliminate the binding, and hence the -allocation, for the function altogether; this is good for join points. -But this only makes sense for *functions*; inlining a constructor -doesn't help allocation unless the result is scrutinised. UNLESS the -constructor occurs just once, albeit possibly in multiple case -branches. Then inlining it doesn't increase allocation, but it does -increase the chance that the constructor won't be allocated at all in -the branches that don't use it. - -Note [Cast then apply] -~~~~~~~~~~~~~~~~~~~~~~ -Consider - myIndex = __inline_me ( (/\a. ) |> 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 varaints, 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. is 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 the -context can ``see'' the unfolding of the variable (e.g. case or a -RULE) so there's no gain. If the thing is bound to a value. - -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 -scrutines 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. - -\begin{code} -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 aovid inlining large functions that return - -- constructors into contexts that are simply "interesting" -\end{code} - -%************************************************************************ -%* * - Interesting arguments -%* * -%************************************************************************ - -Note [Interesting arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An argument is interesting if it deserves a discount for unfoldings -with a discount in that argument position. The idea is to avoid -unfolding a function that is applied only to variables that have no -unfolding (i.e. they are probably lambda bound): f x y z There is -little point in inlining f here. - -Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But -we must look through lets, eg (let x = e in C a b), because the let will -float, exposing the value, if we inline. That makes it different to -exprIsHNF. - -Before 2009 we said it was interesting if the argument had *any* structure -at all; i.e. (hasSomeUnfolding v). But does too much inlining; see Trac #3016. - -But we don't regard (f x y) as interesting, unless f is unsaturated. -If it's saturated and f hasn't inlined, then it's probably not going -to now! - -Note [Conlike is interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f d = ...((*) d x y)... - ... f (df d')... -where df is con-like. Then we'd really like to inline 'f' so that the -rule for (*) (df d) can fire. To do this - a) we give a discount for being an argument of a class-op (eg (*) d) - b) we say that a con-like argument (eg (df d)) is interesting - -\begin{code} -data ArgSummary = TrivArg -- Nothing interesting - | NonTrivArg -- Arg has structure - | ValueArg -- Arg is a con-app or PAP - -- ..or con-like. Note [Conlike is interesting] - -interestingArg :: CoreExpr -> ArgSummary --- See Note [Interesting arguments] -interestingArg e = go e 0 - where - -- n is # value args to which the expression is applied - go (Lit {}) _ = ValueArg - go (Var v) n - | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that - -- data constructors here - | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding - | n > 0 = NonTrivArg -- Saturated or unknown call - | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding - -- See Note [Conlike is interesting] - | otherwise = TrivArg -- n==0, no useful unfolding - where - conlike_unfolding = isConLikeUnfolding (idUnfolding v) - - go (Type _) _ = TrivArg - go (Coercion _) _ = TrivArg - go (App fn (Type _)) n = go fn n - go (App fn (Coercion _)) n = go fn n - go (App fn _) n = go fn (n+1) - go (Tick _ a) n = go a n - go (Cast e _) n = go e n - go (Lam v e) n - | isTyVar v = go e n - | n>0 = go e (n-1) - | otherwise = ValueArg - go (Let _ e) n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg } - go (Case {}) _ = NonTrivArg - -nonTriv :: ArgSummary -> Bool -nonTriv TrivArg = False -nonTriv _ = True -\end{code} diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs new file mode 100644 index 0000000000..ffb327523c --- /dev/null +++ b/compiler/coreSyn/CoreUtils.hs @@ -0,0 +1,1807 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utility functions on @Core@ syntax +-} + +{-# LANGUAGE CPP #-} + +-- | Commonly useful utilites for manipulating the Core language +module CoreUtils ( + -- * Constructing expressions + mkCast, + mkTick, mkTickNoHNF, tickHNFArgs, + bindNonRec, needsCaseBinding, + mkAltExpr, + + -- * Taking expressions apart + findDefault, findAlt, isDefaultAlt, + mergeAlts, trimConArgs, filterAlts, + + -- * Properties of expressions + exprType, coreAltType, coreAltsType, + exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, + exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun, + exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, + exprIsBig, exprIsConLike, + rhsIsStatic, isCheapApp, isExpandableApp, + + -- * Expression and bindings size + coreBindsSize, exprSize, + CoreStats(..), coreBindsStats, + + -- * Equality + cheapEqExpr, eqExpr, + + -- * Eta reduction + tryEtaReduce, + + -- * Manipulating data constructors and types + applyTypeToArgs, applyTypeToArg, + dataConRepInstPat, dataConRepFSInstPat + ) where + +#include "HsVersions.h" + +import CoreSyn +import PprCore +import CoreFVs( exprFreeVars ) +import Var +import SrcLoc +import VarEnv +import VarSet +import Name +import Literal +import DataCon +import PrimOp +import Id +import IdInfo +import Type +import Coercion +import TyCon +import Unique +import Outputable +import TysPrim +import DynFlags +import FastString +import Maybes +import Platform +import Util +import Pair +import Data.List + +{- +************************************************************************ +* * +\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 'CoreSyn.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 = substTyWith [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) = mkPiType 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 (_,bs,rhs) + | any bad_binder bs = expandTypeSynonyms ty + | otherwise = ty -- Note [Existential variables and silly type synonyms] + where + ty = exprType rhs + free_tvs = tyVarsOfType ty + bad_binder b = isTyVar b && b `elemVarSet` free_tvs + +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" + +{- +Note [Type bindings] +~~~~~~~~~~~~~~~~~~~~ +Core does allow type bindings, although such bindings are +not much used, except in the output of the desuguarer. +Example: + let a = Int in (\x:a. x) +Given this, exprType must be careful to substitute 'a' in the +result type (Trac #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 Trac #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. +-} + +applyTypeToArg :: Type -> CoreExpr -> Type +-- ^ Determines the type resulting from applying an expression with given type +-- to a given argument expression +applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty +applyTypeToArg fun_ty _ = funResultTy fun_ty + +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 (_ : 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 + 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 args + = go (applyTysD panic_msg_w_hdr op_ty (reverse rev_tys)) args + + panic_msg_w_hdr = hang (ptext (sLit "applyTypeToArgs")) 2 panic_msg + panic_msg = vcat [ ptext (sLit "Expression:") <+> pprCoreExpr e + , ptext (sLit "Type:") <+> ppr op_ty + , ptext (sLit "Args:") <+> ppr args ] + +{- +************************************************************************ +* * +\subsection{Attaching notes} +* * +************************************************************************ +-} + +-- | Wrap the given expression in the coercion safely, dropping +-- identity coercions and coalescing nested coercions +mkCast :: CoreExpr -> Coercion -> CoreExpr +mkCast e co | ASSERT2( coercionRole co == Representational + , ptext (sLit "coercion") <+> ppr co <+> ptext (sLit "passed to mkCast") <+> ppr e <+> ptext (sLit "has wrong role") <+> ppr (coercionRole co) ) + isReflCo co = e + +mkCast (Coercion e_co) co + | isCoVarType (pSnd (coercionKind 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 { Pair from_ty _to_ty = coercionKind co; + Pair _from_ty2 to_ty2 = coercionKind co2} in + not (from_ty `eqType` to_ty2), + vcat ([ ptext (sLit "expr:") <+> ppr expr + , ptext (sLit "co2:") <+> ppr co2 + , ptext (sLit "co:") <+> ppr co ]) ) + mkCast expr (mkTransCo co2 co) + +mkCast expr co + = let Pair from_ty _to_ty = coercionKind co in +-- if to_ty `eqType` from_ty +-- then expr +-- else + 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 (Var x) + | isFunTy (idType x) = Tick t (Var x) + | otherwise + = if tickishCounts t + then if tickishScoped t && tickishCanSplit t + then Tick (mkNoScope t) (Var x) + else Tick t (Var x) + else Var x + +mkTick t (Cast e co) + = Cast (mkTick t e) co -- Move tick inside cast + +mkTick _ (Coercion co) = Coercion co + +mkTick t (Lit l) + | not (tickishCounts t) = Lit l + +mkTick t expr@(App f arg) + | not (isRuntimeArg arg) = App (mkTick t f) arg + | isSaturatedConApp expr + = if not (tickishCounts t) + then tickHNFArgs t expr + else if tickishScoped t && tickishCanSplit t + then Tick (mkNoScope t) (tickHNFArgs (mkNoCount t) expr) + else Tick t expr + +mkTick t (Lam x e) + -- if this is a type lambda, or the tick does not count entries, + -- then we can push the tick inside: + | not (isRuntimeVar x) || not (tickishCounts t) = Lam x (mkTick t e) + -- if it is both counting and scoped, we split the tick into its + -- two components, 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. + | tickishScoped t && tickishCanSplit t + = Tick (mkNoScope t) (Lam x (mkTick (mkNoCount t) e)) + -- just a counting tick: leave it on the outside + | otherwise = Tick t (Lam x e) + +mkTick t other = Tick t other + +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 + +{- +************************************************************************ +* * +\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 'MkCore.mkCoreLet' +bindNonRec bndr rhs body + | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)] + | otherwise = 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 "CoreSyn#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" + +{- +************************************************************************ +* * +\subsection{Taking expressions apart} +* * +************************************************************************ + +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) + +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* legitmiate + -- 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 + +--------------------------------- +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 agains the pattern + +trimConArgs DEFAULT args = ASSERT( null args ) [] +trimConArgs (LitAlt _) args = ASSERT( null args ) [] +trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args + +filterAlts :: [Unique] -- ^ Supply of uniques used in case we have to manufacture a new AltCon + -> Type -- ^ Type of scrutinee (used to prune possibilities) + -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee + -> [(AltCon, [Var], a)] -- ^ Alternatives + -> ([AltCon], Bool, [(AltCon, [Var], a)]) + -- Returns: + -- 1. Constructors that will never be encountered by the + -- *default* case (if any). A superset of imposs_cons + -- 2. Whether we managed to refine the default alternative into a specific constructor (for statistics only) + -- 3. The new alternatives, trimmed by + -- a) remove imposs_cons + -- b) remove constructors which can't match because of GADTs + -- and with the DEFAULT expanded to a DataAlt if there is exactly + -- remaining constructor that can match + -- + -- 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 us ty imposs_cons alts + | Just (tycon, inst_tys) <- splitTyConApp_maybe ty + = filter_alts tycon inst_tys + | otherwise + = (imposs_cons, False, alts) + where + (alts_wo_default, maybe_deflt) = findDefault alts + alt_cons = [con | (con,_,_) <- alts_wo_default] + + filter_alts tycon inst_tys + = (imposs_deflt_cons, refined_deflt, merged_alts) + where + trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default + + imposs_deflt_cons = nub (imposs_cons ++ alt_cons) + -- "imposs_deflt_cons" are handled + -- EITHER by the context, + -- OR by a non-DEFAULT branch in this case expression. + + merged_alts = mergeAlts trimmed_alts (maybeToList maybe_deflt') + -- We need the mergeAlts in case the new default_alt + -- has turned into a constructor alternative. + -- The merge keeps the inner DEFAULT at the front, if there is one + -- and interleaves the alternatives in the right order + + (refined_deflt, maybe_deflt') = case maybe_deflt of + Nothing -> (False, Nothing) + Just deflt_rhs + | 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 = [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type + impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con + -> case filterOut impossible all_cons of + -- Eliminate the default alternative + -- altogether if it can't match: + [] -> (False, Nothing) + -- It matches exactly one constructor, so fill it in: + [con] -> (True, Just (DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)) + where (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys + _ -> (False, Just (DEFAULT, [], deflt_rhs)) + + | 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 + -> pprTrace "prepareDefault" (ppr tycon) + (False, Just (DEFAULT, [], deflt_rhs)) + + | otherwise -> (False, Just (DEFAULT, [], deflt_rhs)) + + impossible_alt :: [Type] -> (AltCon, a, b) -> Bool + impossible_alt _ (con, _, _) | con `elem` imposs_cons = True + impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con + impossible_alt _ _ = False + +{- +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 Trac #3118.) Then the full-lazines 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. + + +************************************************************************ +* * + 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 [Variable 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 not trivial. If we treat "tick x" as trivial, it will be +inlined inside lambdas and the entry count will be skewed, for +example. Furthermore "scc x" will turn into just "x" in mkTick. +-} + +exprIsTrivial :: CoreExpr -> Bool +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 (Tick _ _) = False -- See Note [Tick trivial] +exprIsTrivial (Cast e _) = exprIsTrivial e +exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body +exprIsTrivial _ = False + +{- +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. +-} + +getIdFromTrivialExpr :: CoreExpr -> Id +getIdFromTrivialExpr e = go e + where go (Var v) = v + go (App f t) | not (isRuntimeArg t) = go f + go (Cast e _) = go e + go (Lam b e) | not (isRuntimeVar b) = go e + go e = pprPanic "getIdFromTrivialExpr" (ppr e) + +{- +exprIsBottom is a very cheap and cheerful function; it may return +False for bottoming expressions, but it never costs much to ask. See +also CoreArity.exprBotStrictness_maybe, but that's a bit more +expensive. +-} + +exprIsBottom :: CoreExpr -> Bool +exprIsBottom e + = 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 _ _ = False + +{- +************************************************************************ +* * + 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 Trac #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 (Trac #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) +-} + +exprIsWorkFree :: CoreExpr -> Bool +-- See Note [exprIsWorkFree] +exprIsWorkFree e = go 0 e + where -- n is the number of value arguments + go _ (Lit {}) = True + go _ (Type {}) = True + go _ (Coercion {}) = True + go n (Cast e _) = go n e + go n (Case scrut _ _ alts) = foldl (&&) (exprIsWorkFree scrut) + [ go n rhs | (_,_,rhs) <- alts ] + -- See Note [Case expressions are work-free] + go _ (Let {}) = False + go n (Var v) = isCheapApp v n + 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 = exprIsWorkFree e && go (n+1) f + | otherwise = go n f + +{- +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. + + +Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables] +~~~~~~~~~~~~~~~~~~ in CoreUnfold.lhs +@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. +-} + +exprIsCheap :: CoreExpr -> Bool +exprIsCheap = exprIsCheap' isCheapApp + +exprIsExpandable :: CoreExpr -> Bool +exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes + +exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool +exprIsCheap' _ (Lit _) = True +exprIsCheap' _ (Type _) = True +exprIsCheap' _ (Coercion _) = True +exprIsCheap' _ (Var _) = True +exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e +exprIsCheap' good_app (Lam x e) = isRuntimeVar x + || exprIsCheap' good_app e + +exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e && + and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts] + -- Experimentally, treat (case x of ...) as cheap + -- (and case __coerce x etc.) + -- This improves arities of overloaded functions where + -- there is only dictionary selection (no construction) involved + +exprIsCheap' good_app (Tick t e) + | tickishCounts t = False + | otherwise = exprIsCheap' good_app e + -- never duplicate ticks. If we get this wrong, then HPC's entry + -- counts will be off (check test in libraries/hpc/tests/raytrace) + +exprIsCheap' good_app (Let (NonRec _ b) e) + = exprIsCheap' good_app b && exprIsCheap' good_app e +exprIsCheap' good_app (Let (Rec prs) e) + = all (exprIsCheap' good_app . snd) prs && exprIsCheap' good_app e + +exprIsCheap' good_app other_expr -- Applications and variables + = go other_expr [] + where + -- Accumulate value arguments, then decide + go (Cast e _) val_args = go e val_args + go (App f a) val_args | isRuntimeArg a = go f (a:val_args) + | otherwise = go f val_args + + go (Var _) [] = True + -- Just a type application of a variable + -- (f t1 t2 t3) counts as WHNF + -- This case is probably handeld by the good_app case + -- below, which should have a case for n=0, but putting + -- it here too is belt and braces; and it's such a common + -- case that checking for null directly seems like a + -- good plan + + go (Var f) args + | good_app f (length args) + = go_pap args + + | otherwise + = case idDetails f of + RecSelId {} -> go_sel args + ClassOpId {} -> go_sel args + PrimOpId op -> go_primop op args + _ | isBottomingId f -> True + | otherwise -> False + -- Application of a function which + -- always gives bottom; we treat this as cheap + -- because it certainly doesn't need to be shared! + + go _ _ = False + + -------------- + go_pap args = all (exprIsCheap' good_app) args + -- Used to be "all exprIsTrivial args" due to concerns about + -- duplicating nested constructor applications, but see #4978. + -- The principle here is that + -- let x = a +# b in c *# x + -- should behave equivalently to + -- c *# (a +# b) + -- Since lets with cheap RHSs are accepted, + -- so should paps with cheap arguments + + -------------- + go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args + -- In principle we should worry about primops + -- that return a type variable, since the result + -- might be applied to something, but I'm not going + -- to bother to check the number of args + + -------------- + go_sel [arg] = exprIsCheap' good_app arg -- I'm experimenting with making record selection + go_sel _ = False -- look cheap, so we will substitute it inside a + -- lambda. Particularly for dictionary field selection. + -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but + -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) + +------------------------------------- +type CheapAppFun = Id -> Int -> Bool + -- Is an application of this function to n *value* args + -- always cheap, assuming the arguments are cheap? + -- Mainly true of partial applications, data constructors, + -- and of course true if the number of args is zero + +isCheapApp :: CheapAppFun +isCheapApp fn n_val_args + = isDataConWorkId fn + || n_val_args == 0 + || n_val_args < idArity fn + +isExpandableApp :: CheapAppFun +isExpandableApp fn n_val_args + = isConLikeId fn + || n_val_args < idArity fn + || go n_val_args (idType fn) + where + -- See if all the arguments are PredTys (implicit params or classes) + -- If so we'll regard it as expandable; see Note [Expandable overloadings] + -- This incidentally picks up the (n_val_args = 0) case + go 0 _ = True + go n_val_args ty + | Just (_, ty) <- splitForAllTy_maybe ty = go n_val_args ty + | Just (arg, ty) <- splitFunTy_maybe ty + , isPredTy arg = go (n_val_args-1) ty + | otherwise = False + +{- +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 [Implementation: how can_fail/has_side_effects affect transformations] +-- +-- 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 :: Expr b -> Bool +exprOkForSpeculation = expr_ok primOpOkForSpeculation +exprOkForSideEffects = expr_ok primOpOkForSideEffects + -- Polymorphic in binder type + -- There is one call at a non-Id binder type, in SetLevels + +expr_ok :: (PrimOp -> Bool) -> Expr b -> 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 + +-- 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 primop_ok (Case e _ _ alts) + = expr_ok primop_ok e -- Note [exprOkForSpeculation: case expressions] + && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts + && altsAreExhaustive alts -- Note [Exhaustive alts] + +expr_ok primop_ok other_expr + = case collectArgs other_expr of + (Var f, args) -> app_ok primop_ok f args + _ -> False + +----------------------------- +app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> 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 -- Special case for dividing operations that fail + , [arg1, Lit lit] <- args -- only if the divisor is zero + -> not (isZeroLit lit) && expr_ok primop_ok arg1 + -- Often there is a literal divisor, and this + -- can get rid of a thunk in an inner looop + + | DataToTagOp <- op -- See Note [dataToTag speculation] + -> True + + | otherwise + -> primop_ok op -- A bit conservative: we don't really need + && all (expr_ok primop_ok) args -- to care about lazy arguments, but this is easy + + _other -> isUnLiftedType (idType fun) -- c.f. the Var case of exprIsHNF + || idArity fun > n_val_args -- Partial apps + || (n_val_args == 0 && + isEvaldUnfolding (idUnfolding fun)) -- Let-bound values + where + n_val_args = valArgCount args + +----------------------------- +altsAreExhaustive :: [Alt b] -> Bool +-- True <=> the case alternatives are definiely 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 -> 1 + length alts == tyConFamilySize (dataConTyCon c) + -- 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's always sound for exprOkForSpeculation to return False, and we +don't want it to take too long, so it bales out on complicated-looking +terms. Notably lets, which can be stacked very deeply; and in any +case the argument of exprOkForSpeculation is usually in a strict context, +so any lets will have been floated away. + +However, we keep going on case-expressions. An example like this one +showed up in DPH code (Trac #3717): + foo :: Int -> Int + foo 0 = 0 + foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) + +If exprOkForSpeculation doesn't look through case expressions, you get 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 + } + +The inner case is redundant, and should be nuked. + +Note [Exhaustive alts] +~~~~~~~~~~~~~~~~~~~~~~ +We might have something like + case x of { + A -> ... + _ -> ...(case x of { B -> ...; C -> ... })... +Here, the inner case is fine, because the A alternative +can't happen, but it's not ok to float the inner case outside +the outer one (even if we know x is evaluated outside), because +then it would be non-exhaustive. See Trac #5453. + +Similarly, this is a valid program (albeit a slightly dodgy one) + let v = case x of { B -> ...; C -> ... } + in case x of + A -> ... + _ -> ...v...v.... +But we don't want to speculate the v binding. + +One could try to be clever, but the easy fix is simpy to regard +a non-exhaustive case as *not* okForSpeculation. + + +Note [dataToTag speculation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is this OK? + f x = let v::Int# = dataToTag# x + in ... +We say "yes", even though 'x' may not be evaluated. Reasons + + * dataToTag#'s strictness means that its argument often will be + evaluated, but FloatOut makes that temporarily untrue + case x of y -> let v = dataToTag# y in ... + --> + case x of y -> let v = dataToTag# x in ... + Note that we look at 'x' instead of 'y' (this is to improve + floating in FloatOut). So Lint complains. + + Moreover, it really *might* improve floating to let the + v-binding float out + + * CorePrep makes sure dataToTag#'s argument is evaluated, just + before code gen. Until then, it's not guaranteed + + +************************************************************************ +* * + 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 "CoreSyn#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 + = is_con v -- Catches nullary constructors, + -- so that [] and () are values, for example + || idArity v > 0 -- Catches (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 + -- 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 (Type _)) = is_hnf_like e + is_hnf_like (App e (Coercion _)) = is_hnf_like e + is_hnf_like (App e a) = app_is_value e [a] + is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us + is_hnf_like _ = False + + -- There is at least one value argument + app_is_value :: CoreExpr -> [CoreArg] -> Bool + app_is_value (Var fun) args + = idArity fun > valArgCount args -- Under-applied function + || is_con fun -- or constructor-like + app_is_value (Tick _ f) as = app_is_value f as + app_is_value (Cast f _) as = app_is_value f as + app_is_value (App f a) as = app_is_value f (a:as) + app_is_value _ _ = False + +{- +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. +-} + +{- +************************************************************************ +* * + Instantiating data constructors +* * +************************************************************************ + +These InstPat functions go here to avoid circularity between DataCon and Id +-} + +dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) +dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [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 + -> ([TyVar], [Id]) -- Return instantiated variables +-- dataConInstPat arg_fun fss us con inst_tys returns a triple +-- (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 = dataConExTyVars 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 = zipOpenTvSubst univ_tvs inst_tys + + -- Make existential type variables, applyingn and extending the substitution + (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst + (zip3 ex_tvs ex_fss ex_uniqs) + + mk_ex_var :: TvSubst -> (TyVar, FastString, Unique) -> (TvSubst, TyVar) + mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubst subst tv (mkTyVarTy new_tv) + , new_tv) + where + new_tv = mkTyVar new_name kind + new_name = mkSysTvName uniq fs + kind = Type.substTy subst (tyVarKind 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 + = mkLocalIdWithInfo name (Type.substTy full_subst ty) info + where + name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan + info | isMarkedStrict str = vanillaIdInfo `setUnfoldingInfo` evaldUnfolding + | otherwise = vanillaIdInfo + -- See Note [Mark evaluated arguments] + +{- +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 (Var v1) (Var v2) = v1==v2 +cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2 +cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2 +cheapEqExpr (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2 + +cheapEqExpr (App f1 a1) (App f2 a2) + = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 + +cheapEqExpr (Cast e1 t1) (Cast e2 t2) + = e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2 + +cheapEqExpr _ _ = False + +exprIsBig :: Expr b -> Bool +-- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' +exprIsBig (Lit _) = False +exprIsBig (Var _) = 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 _ = 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) = coreEqCoercion2 env co1 co2 + go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 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) = go_tickish 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) + = 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 + + ----------- + go_tickish env (Breakpoint lid lids) (Breakpoint rid rids) + = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids + go_tickish _ l r = l == r + +{- +************************************************************************ +* * +\subsection{The size of an expression} +* * +************************************************************************ +-} + +data CoreStats = CS { cs_tm :: Int -- Terms + , cs_ty :: Int -- Types + , cs_co :: Int } -- Coercions + + +instance Outputable CoreStats where + ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) + = braces (sep [ptext (sLit "terms:") <+> intWithCommas i1 <> comma, + ptext (sLit "types:") <+> intWithCommas i2 <> comma, + ptext (sLit "coercions:") <+> intWithCommas i3]) + +plusCS :: CoreStats -> CoreStats -> CoreStats +plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 }) + (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 }) + = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2 } + +zeroCS, oneTM :: CoreStats +zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0 } +oneTM = zeroCS { cs_tm = 1 } + +sumCS :: (a -> CoreStats) -> [a] -> CoreStats +sumCS f = foldr (plusCS . f) zeroCS + +coreBindsStats :: [CoreBind] -> CoreStats +coreBindsStats = sumCS bindStats + +bindStats :: CoreBind -> CoreStats +bindStats (NonRec v r) = bindingStats v r +bindStats (Rec prs) = sumCS (\(v,r) -> bindingStats v r) prs + +bindingStats :: Var -> CoreExpr -> CoreStats +bindingStats v r = bndrStats v `plusCS` exprStats r + +bndrStats :: Var -> CoreStats +bndrStats v = oneTM `plusCS` 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 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 = foldr ((+) . bindSize) 0 bs + +exprSize :: CoreExpr -> Int +-- ^ A measure of the size of the expressions, strictly greater than 0 +-- It also forces the expression pretty drastically as a side effect +-- Counts *leaves*, not internal nodes. Types and coercions are not counted. +exprSize (Var v) = v `seq` 1 +exprSize (Lit lit) = lit `seq` 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 t as) = seqType t `seq` exprSize e + bndrSize b + 1 + foldr ((+) . altSize) 0 as +exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e +exprSize (Tick n e) = tickSize n + exprSize e +exprSize (Type t) = seqType t `seq` 1 +exprSize (Coercion co) = seqCo co `seq` 1 + +tickSize :: Tickish Id -> Int +tickSize (ProfNote cc _ _) = cc `seq` 1 +tickSize _ = 1 -- the rest are strict + +bndrSize :: Var -> Int +bndrSize b | isTyVar b = seqType (tyVarKind b) `seq` 1 + | otherwise = seqType (idType b) `seq` + megaSeqIdInfo (idInfo b) `seq` + 1 + +bndrsSize :: [Var] -> Int +bndrsSize = sum . map bndrSize + +bindSize :: CoreBind -> Int +bindSize (NonRec b e) = bndrSize b + exprSize e +bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs + +pairSize :: (Var, CoreExpr) -> Int +pairSize (b,e) = bndrSize b + exprSize e + +altSize :: CoreAlt -> Int +altSize (c,bs,e) = c `seq` bndrsSize bs + exprSize e + +{- +************************************************************************ +* * + 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 Trac #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. +-} + +tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr +tryEtaReduce bndrs body + = go (reverse bndrs) body (mkReflCo Representational (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 (b : bs) (App fun arg) co + | Just co' <- ok_arg b arg co + = go bs fun co' + + go _ _ _ = Nothing -- Failure! + + --------------- + -- Note [Eta reduction conditions] + ok_fun (App fun (Type {})) = ok_fun fun + ok_fun (Cast fun _) = ok_fun fun + 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) + -- See Note [Eta reduction with casted arguments] + ok_arg bndr (Type ty) co + | Just tv <- getTyVar_maybe ty + , bndr == tv = Just (mkForAllCo tv co) + ok_arg bndr (Var v) co + | bndr == v = Just (mkFunCo Representational + (mkReflCo Representational (idType bndr)) co) + ok_arg bndr (Cast (Var v) co_arg) co + | bndr == v = Just (mkFunCo Representational (mkSymCo co_arg) co) + -- The simplifier combines multiple casts into one, + -- so we can have a simple-minded pattern match here + ok_arg _ _ _ = Nothing + +{- +Note [Eta reduction of an eval'd function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Haskell is 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 Trac #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. +-} + +-- | This function is called only on *top-level* right-hand sides. +-- Returns @True@ if the RHS can be allocated statically in the output, +-- with no thunks involved at all. +rhsIsStatic :: Platform -> (Name -> Bool) -> CoreExpr -> Bool +-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or +-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an +-- update flag on it and (iii) in DsExpr to decide how to expand +-- list literals +-- +-- The basic idea is that rhsIsStatic returns True only if the RHS is +-- (a) a value lambda +-- (b) a saturated constructor application with static args +-- +-- BUT watch out for +-- (i) Any cross-DLL references kill static-ness completely +-- because they must be 'executed' not statically allocated +-- ("DLL" here really only refers to Windows DLLs, on other platforms, +-- this is not necessary) +-- +-- (ii) We treat partial applications as redexes, because in fact we +-- make a thunk for them that runs and builds a PAP +-- at run-time. The only appliations that are treated as +-- static are *saturated* applications of constructors. + +-- We used to try to be clever with nested structures like this: +-- ys = (:) w ((:) w []) +-- on the grounds that CorePrep will flatten ANF-ise it later. +-- But supporting this special case made the function much more +-- complicated, because the special case only applies if there are no +-- enclosing type lambdas: +-- ys = /\ a -> Foo (Baz ([] a)) +-- Here the nested (Baz []) won't float out to top level in CorePrep. +-- +-- But in fact, even without -O, nested structures at top level are +-- flattened by the simplifier, so we don't need to be super-clever here. +-- +-- Examples +-- +-- f = \x::Int. x+7 TRUE +-- p = (True,False) TRUE +-- +-- d = (fst p, False) FALSE because there's a redex inside +-- (this particular one doesn't happen but...) +-- +-- h = D# (1.0## /## 2.0##) FALSE (redex again) +-- n = /\a. Nil a TRUE +-- +-- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex) +-- +-- +-- This is a bit like CoreUtils.exprIsHNF, with the following differences: +-- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) +-- +-- b) (C x xs), where C is a contructor is updatable if the application is +-- dynamic +-- +-- c) don't look through unfolding of f in (f x). + +rhsIsStatic platform is_dynamic_name rhs = is_static False rhs + where + is_static :: Bool -- True <=> in a constructor argument; must be atomic + -> CoreExpr -> Bool + + is_static False (Lam b e) = isRuntimeVar b || is_static False e + is_static in_arg (Tick n e) = not (tickishIsCode n) + && is_static in_arg e + is_static in_arg (Cast e _) = is_static in_arg e + is_static _ (Coercion {}) = True -- Behaves just like a literal + is_static _ (Lit (LitInteger {})) = False + is_static _ (Lit (MachLabel {})) = False + is_static _ (Lit _) = True + -- A MachLabel (foreign import "&foo") in an argument + -- prevents a constructor application from being static. The + -- reason is that it might give rise to unresolvable symbols + -- in the object file: under Linux, references to "weak" + -- symbols from the data segment give rise to "unresolvable + -- relocation" errors at link time This might be due to a bug + -- in the linker, but we'll work around it here anyway. + -- SDM 24/2/2004 + + is_static in_arg other_expr = go other_expr 0 + where + go (Var f) n_val_args + | (platformOS platform /= OSMinGW32) || + not (is_dynamic_name (idName f)) + = saturated_data_con f n_val_args + || (in_arg && n_val_args == 0) + -- A naked un-applied variable is *not* deemed a static RHS + -- E.g. f = g + -- Reason: better to update so that the indirection gets shorted + -- out, and the true value will be seen + -- NB: if you change this, you'll break the invariant that THUNK_STATICs + -- are always updatable. If you do so, make sure that non-updatable + -- ones have enough space for their static link field! + + go (App f a) n_val_args + | isTypeArg a = go f n_val_args + | not in_arg && is_static True a = go f (n_val_args + 1) + -- The (not in_arg) checks that we aren't in a constructor argument; + -- if we are, we don't allow (value) applications of any sort + -- + -- NB. In case you wonder, args are sometimes not atomic. eg. + -- x = D# (1.0## /## 2.0##) + -- can't float because /## can fail. + + go (Tick n f) n_val_args = not (tickishIsCode n) && go f n_val_args + go (Cast e _) n_val_args = go e n_val_args + go _ _ = False + + saturated_data_con f n_val_args + = case isDataConWorkId_maybe f of + Just dc -> n_val_args == dataConRepArity dc + Nothing -> False diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs deleted file mode 100644 index 86db946f26..0000000000 --- a/compiler/coreSyn/CoreUtils.lhs +++ /dev/null @@ -1,1829 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -Utility functions on @Core@ syntax - -\begin{code} -{-# LANGUAGE CPP #-} - --- | Commonly useful utilites for manipulating the Core language -module CoreUtils ( - -- * Constructing expressions - mkCast, - mkTick, mkTickNoHNF, tickHNFArgs, - bindNonRec, needsCaseBinding, - mkAltExpr, - - -- * Taking expressions apart - findDefault, findAlt, isDefaultAlt, - mergeAlts, trimConArgs, filterAlts, - - -- * Properties of expressions - exprType, coreAltType, coreAltsType, - exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, - exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun, - exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, - exprIsBig, exprIsConLike, - rhsIsStatic, isCheapApp, isExpandableApp, - - -- * Expression and bindings size - coreBindsSize, exprSize, - CoreStats(..), coreBindsStats, - - -- * Equality - cheapEqExpr, eqExpr, - - -- * Eta reduction - tryEtaReduce, - - -- * Manipulating data constructors and types - applyTypeToArgs, applyTypeToArg, - dataConRepInstPat, dataConRepFSInstPat - ) where - -#include "HsVersions.h" - -import CoreSyn -import PprCore -import CoreFVs( exprFreeVars ) -import Var -import SrcLoc -import VarEnv -import VarSet -import Name -import Literal -import DataCon -import PrimOp -import Id -import IdInfo -import Type -import Coercion -import TyCon -import Unique -import Outputable -import TysPrim -import DynFlags -import FastString -import Maybes -import Platform -import Util -import Pair -import Data.List -\end{code} - - -%************************************************************************ -%* * -\subsection{Find the type of a Core atom/expression} -%* * -%************************************************************************ - -\begin{code} -exprType :: CoreExpr -> Type --- ^ Recover the type of a well-typed Core expression. Fails when --- applied to the actual 'CoreSyn.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 = substTyWith [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) = mkPiType 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 (_,bs,rhs) - | any bad_binder bs = expandTypeSynonyms ty - | otherwise = ty -- Note [Existential variables and silly type synonyms] - where - ty = exprType rhs - free_tvs = tyVarsOfType ty - bad_binder b = isTyVar b && b `elemVarSet` free_tvs - -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" -\end{code} - -Note [Type bindings] -~~~~~~~~~~~~~~~~~~~~ -Core does allow type bindings, although such bindings are -not much used, except in the output of the desuguarer. -Example: - let a = Int in (\x:a. x) -Given this, exprType must be careful to substitute 'a' in the -result type (Trac #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 Trac #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. - -\begin{code} -applyTypeToArg :: Type -> CoreExpr -> Type --- ^ Determines the type resulting from applying an expression with given type --- to a given argument expression -applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty -applyTypeToArg fun_ty _ = funResultTy fun_ty - -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 (_ : 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 - 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 args - = go (applyTysD panic_msg_w_hdr op_ty (reverse rev_tys)) args - - panic_msg_w_hdr = hang (ptext (sLit "applyTypeToArgs")) 2 panic_msg - panic_msg = vcat [ ptext (sLit "Expression:") <+> pprCoreExpr e - , ptext (sLit "Type:") <+> ppr op_ty - , ptext (sLit "Args:") <+> ppr args ] -\end{code} - -%************************************************************************ -%* * -\subsection{Attaching notes} -%* * -%************************************************************************ - -\begin{code} --- | Wrap the given expression in the coercion safely, dropping --- identity coercions and coalescing nested coercions -mkCast :: CoreExpr -> Coercion -> CoreExpr -mkCast e co | ASSERT2( coercionRole co == Representational - , ptext (sLit "coercion") <+> ppr co <+> ptext (sLit "passed to mkCast") <+> ppr e <+> ptext (sLit "has wrong role") <+> ppr (coercionRole co) ) - isReflCo co = e - -mkCast (Coercion e_co) co - | isCoVarType (pSnd (coercionKind 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 { Pair from_ty _to_ty = coercionKind co; - Pair _from_ty2 to_ty2 = coercionKind co2} in - not (from_ty `eqType` to_ty2), - vcat ([ ptext (sLit "expr:") <+> ppr expr - , ptext (sLit "co2:") <+> ppr co2 - , ptext (sLit "co:") <+> ppr co ]) ) - mkCast expr (mkTransCo co2 co) - -mkCast expr co - = let Pair from_ty _to_ty = coercionKind co in --- if to_ty `eqType` from_ty --- then expr --- else - 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) -\end{code} - -\begin{code} --- | Wraps the given expression in the source annotation, dropping the --- annotation if possible. -mkTick :: Tickish Id -> CoreExpr -> CoreExpr - -mkTick t (Var x) - | isFunTy (idType x) = Tick t (Var x) - | otherwise - = if tickishCounts t - then if tickishScoped t && tickishCanSplit t - then Tick (mkNoScope t) (Var x) - else Tick t (Var x) - else Var x - -mkTick t (Cast e co) - = Cast (mkTick t e) co -- Move tick inside cast - -mkTick _ (Coercion co) = Coercion co - -mkTick t (Lit l) - | not (tickishCounts t) = Lit l - -mkTick t expr@(App f arg) - | not (isRuntimeArg arg) = App (mkTick t f) arg - | isSaturatedConApp expr - = if not (tickishCounts t) - then tickHNFArgs t expr - else if tickishScoped t && tickishCanSplit t - then Tick (mkNoScope t) (tickHNFArgs (mkNoCount t) expr) - else Tick t expr - -mkTick t (Lam x e) - -- if this is a type lambda, or the tick does not count entries, - -- then we can push the tick inside: - | not (isRuntimeVar x) || not (tickishCounts t) = Lam x (mkTick t e) - -- if it is both counting and scoped, we split the tick into its - -- two components, 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. - | tickishScoped t && tickishCanSplit t - = Tick (mkNoScope t) (Lam x (mkTick (mkNoCount t) e)) - -- just a counting tick: leave it on the outside - | otherwise = Tick t (Lam x e) - -mkTick t other = Tick t other - -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 -\end{code} - -%************************************************************************ -%* * -\subsection{Other expression construction} -%* * -%************************************************************************ - -\begin{code} -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 'MkCore.mkCoreLet' -bindNonRec bndr rhs body - | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)] - | otherwise = 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 "CoreSyn#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) -\end{code} - -\begin{code} -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" -\end{code} - - -%************************************************************************ -%* * -\subsection{Taking expressions apart} -%* * -%************************************************************************ - -The default alternative must be first, if it exists at all. -This makes it easy to find, though it makes matching marginally harder. - -\begin{code} --- | 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) - -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* legitmiate - -- 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 - ---------------------------------- -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 agains the pattern - -trimConArgs DEFAULT args = ASSERT( null args ) [] -trimConArgs (LitAlt _) args = ASSERT( null args ) [] -trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args -\end{code} - -\begin{code} -filterAlts :: [Unique] -- ^ Supply of uniques used in case we have to manufacture a new AltCon - -> Type -- ^ Type of scrutinee (used to prune possibilities) - -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee - -> [(AltCon, [Var], a)] -- ^ Alternatives - -> ([AltCon], Bool, [(AltCon, [Var], a)]) - -- Returns: - -- 1. Constructors that will never be encountered by the - -- *default* case (if any). A superset of imposs_cons - -- 2. Whether we managed to refine the default alternative into a specific constructor (for statistics only) - -- 3. The new alternatives, trimmed by - -- a) remove imposs_cons - -- b) remove constructors which can't match because of GADTs - -- and with the DEFAULT expanded to a DataAlt if there is exactly - -- remaining constructor that can match - -- - -- 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 us ty imposs_cons alts - | Just (tycon, inst_tys) <- splitTyConApp_maybe ty - = filter_alts tycon inst_tys - | otherwise - = (imposs_cons, False, alts) - where - (alts_wo_default, maybe_deflt) = findDefault alts - alt_cons = [con | (con,_,_) <- alts_wo_default] - - filter_alts tycon inst_tys - = (imposs_deflt_cons, refined_deflt, merged_alts) - where - trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default - - imposs_deflt_cons = nub (imposs_cons ++ alt_cons) - -- "imposs_deflt_cons" are handled - -- EITHER by the context, - -- OR by a non-DEFAULT branch in this case expression. - - merged_alts = mergeAlts trimmed_alts (maybeToList maybe_deflt') - -- We need the mergeAlts in case the new default_alt - -- has turned into a constructor alternative. - -- The merge keeps the inner DEFAULT at the front, if there is one - -- and interleaves the alternatives in the right order - - (refined_deflt, maybe_deflt') = case maybe_deflt of - Nothing -> (False, Nothing) - Just deflt_rhs - | 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 = [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type - impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con - -> case filterOut impossible all_cons of - -- Eliminate the default alternative - -- altogether if it can't match: - [] -> (False, Nothing) - -- It matches exactly one constructor, so fill it in: - [con] -> (True, Just (DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)) - where (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys - _ -> (False, Just (DEFAULT, [], deflt_rhs)) - - | 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 - -> pprTrace "prepareDefault" (ppr tycon) - (False, Just (DEFAULT, [], deflt_rhs)) - - | otherwise -> (False, Just (DEFAULT, [], deflt_rhs)) - - impossible_alt :: [Type] -> (AltCon, a, b) -> Bool - impossible_alt _ (con, _, _) | con `elem` imposs_cons = True - impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con - impossible_alt _ _ = False -\end{code} - -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 Trac #3118.) Then the full-lazines 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. - - -%************************************************************************ -%* * - 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 [Variable 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 not trivial. If we treat "tick x" as trivial, it will be -inlined inside lambdas and the entry count will be skewed, for -example. Furthermore "scc x" will turn into just "x" in mkTick. - -\begin{code} -exprIsTrivial :: CoreExpr -> Bool -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 (Tick _ _) = False -- See Note [Tick trivial] -exprIsTrivial (Cast e _) = exprIsTrivial e -exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body -exprIsTrivial _ = False -\end{code} - -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. - -\begin{code} -getIdFromTrivialExpr :: CoreExpr -> Id -getIdFromTrivialExpr e = go e - where go (Var v) = v - go (App f t) | not (isRuntimeArg t) = go f - go (Cast e _) = go e - go (Lam b e) | not (isRuntimeVar b) = go e - go e = pprPanic "getIdFromTrivialExpr" (ppr e) -\end{code} - -exprIsBottom is a very cheap and cheerful function; it may return -False for bottoming expressions, but it never costs much to ask. See -also CoreArity.exprBotStrictness_maybe, but that's a bit more -expensive. - -\begin{code} -exprIsBottom :: CoreExpr -> Bool -exprIsBottom e - = 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 _ _ = False -\end{code} - - -%************************************************************************ -%* * - 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 - - -\begin{code} -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 Trac #4960. -\end{code} - -%************************************************************************ -%* * - 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 (Trac #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) - -\begin{code} -exprIsWorkFree :: CoreExpr -> Bool --- See Note [exprIsWorkFree] -exprIsWorkFree e = go 0 e - where -- n is the number of value arguments - go _ (Lit {}) = True - go _ (Type {}) = True - go _ (Coercion {}) = True - go n (Cast e _) = go n e - go n (Case scrut _ _ alts) = foldl (&&) (exprIsWorkFree scrut) - [ go n rhs | (_,_,rhs) <- alts ] - -- See Note [Case expressions are work-free] - go _ (Let {}) = False - go n (Var v) = isCheapApp v n - 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 = exprIsWorkFree e && go (n+1) f - | otherwise = go n f -\end{code} - -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. - - -Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables] -~~~~~~~~~~~~~~~~~~ in CoreUnfold.lhs -@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. - -\begin{code} -exprIsCheap :: CoreExpr -> Bool -exprIsCheap = exprIsCheap' isCheapApp - -exprIsExpandable :: CoreExpr -> Bool -exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes - -exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool -exprIsCheap' _ (Lit _) = True -exprIsCheap' _ (Type _) = True -exprIsCheap' _ (Coercion _) = True -exprIsCheap' _ (Var _) = True -exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e -exprIsCheap' good_app (Lam x e) = isRuntimeVar x - || exprIsCheap' good_app e - -exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e && - and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts] - -- Experimentally, treat (case x of ...) as cheap - -- (and case __coerce x etc.) - -- This improves arities of overloaded functions where - -- there is only dictionary selection (no construction) involved - -exprIsCheap' good_app (Tick t e) - | tickishCounts t = False - | otherwise = exprIsCheap' good_app e - -- never duplicate ticks. If we get this wrong, then HPC's entry - -- counts will be off (check test in libraries/hpc/tests/raytrace) - -exprIsCheap' good_app (Let (NonRec _ b) e) - = exprIsCheap' good_app b && exprIsCheap' good_app e -exprIsCheap' good_app (Let (Rec prs) e) - = all (exprIsCheap' good_app . snd) prs && exprIsCheap' good_app e - -exprIsCheap' good_app other_expr -- Applications and variables - = go other_expr [] - where - -- Accumulate value arguments, then decide - go (Cast e _) val_args = go e val_args - go (App f a) val_args | isRuntimeArg a = go f (a:val_args) - | otherwise = go f val_args - - go (Var _) [] = True - -- Just a type application of a variable - -- (f t1 t2 t3) counts as WHNF - -- This case is probably handeld by the good_app case - -- below, which should have a case for n=0, but putting - -- it here too is belt and braces; and it's such a common - -- case that checking for null directly seems like a - -- good plan - - go (Var f) args - | good_app f (length args) - = go_pap args - - | otherwise - = case idDetails f of - RecSelId {} -> go_sel args - ClassOpId {} -> go_sel args - PrimOpId op -> go_primop op args - _ | isBottomingId f -> True - | otherwise -> False - -- Application of a function which - -- always gives bottom; we treat this as cheap - -- because it certainly doesn't need to be shared! - - go _ _ = False - - -------------- - go_pap args = all (exprIsCheap' good_app) args - -- Used to be "all exprIsTrivial args" due to concerns about - -- duplicating nested constructor applications, but see #4978. - -- The principle here is that - -- let x = a +# b in c *# x - -- should behave equivalently to - -- c *# (a +# b) - -- Since lets with cheap RHSs are accepted, - -- so should paps with cheap arguments - - -------------- - go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args - -- In principle we should worry about primops - -- that return a type variable, since the result - -- might be applied to something, but I'm not going - -- to bother to check the number of args - - -------------- - go_sel [arg] = exprIsCheap' good_app arg -- I'm experimenting with making record selection - go_sel _ = False -- look cheap, so we will substitute it inside a - -- lambda. Particularly for dictionary field selection. - -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but - -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) - -------------------------------------- -type CheapAppFun = Id -> Int -> Bool - -- Is an application of this function to n *value* args - -- always cheap, assuming the arguments are cheap? - -- Mainly true of partial applications, data constructors, - -- and of course true if the number of args is zero - -isCheapApp :: CheapAppFun -isCheapApp fn n_val_args - = isDataConWorkId fn - || n_val_args == 0 - || n_val_args < idArity fn - -isExpandableApp :: CheapAppFun -isExpandableApp fn n_val_args - = isConLikeId fn - || n_val_args < idArity fn - || go n_val_args (idType fn) - where - -- See if all the arguments are PredTys (implicit params or classes) - -- If so we'll regard it as expandable; see Note [Expandable overloadings] - -- This incidentally picks up the (n_val_args = 0) case - go 0 _ = True - go n_val_args ty - | Just (_, ty) <- splitForAllTy_maybe ty = go n_val_args ty - | Just (arg, ty) <- splitFunTy_maybe ty - , isPredTy arg = go (n_val_args-1) ty - | otherwise = False -\end{code} - -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 -%* * -%************************************************************************ - -\begin{code} ------------------------------ --- | '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 [Implementation: how can_fail/has_side_effects affect transformations] --- --- 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 :: Expr b -> Bool -exprOkForSpeculation = expr_ok primOpOkForSpeculation -exprOkForSideEffects = expr_ok primOpOkForSideEffects - -- Polymorphic in binder type - -- There is one call at a non-Id binder type, in SetLevels - -expr_ok :: (PrimOp -> Bool) -> Expr b -> 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 - --- 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 primop_ok (Case e _ _ alts) - = expr_ok primop_ok e -- Note [exprOkForSpeculation: case expressions] - && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts - && altsAreExhaustive alts -- Note [Exhaustive alts] - -expr_ok primop_ok other_expr - = case collectArgs other_expr of - (Var f, args) -> app_ok primop_ok f args - _ -> False - ------------------------------ -app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> 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 -- Special case for dividing operations that fail - , [arg1, Lit lit] <- args -- only if the divisor is zero - -> not (isZeroLit lit) && expr_ok primop_ok arg1 - -- Often there is a literal divisor, and this - -- can get rid of a thunk in an inner looop - - | DataToTagOp <- op -- See Note [dataToTag speculation] - -> True - - | otherwise - -> primop_ok op -- A bit conservative: we don't really need - && all (expr_ok primop_ok) args -- to care about lazy arguments, but this is easy - - _other -> isUnLiftedType (idType fun) -- c.f. the Var case of exprIsHNF - || idArity fun > n_val_args -- Partial apps - || (n_val_args == 0 && - isEvaldUnfolding (idUnfolding fun)) -- Let-bound values - where - n_val_args = valArgCount args - ------------------------------ -altsAreExhaustive :: [Alt b] -> Bool --- True <=> the case alternatives are definiely 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 -> 1 + length alts == tyConFamilySize (dataConTyCon c) - -- 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 -\end{code} - -Note [exprOkForSpeculation: case expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's always sound for exprOkForSpeculation to return False, and we -don't want it to take too long, so it bales out on complicated-looking -terms. Notably lets, which can be stacked very deeply; and in any -case the argument of exprOkForSpeculation is usually in a strict context, -so any lets will have been floated away. - -However, we keep going on case-expressions. An example like this one -showed up in DPH code (Trac #3717): - foo :: Int -> Int - foo 0 = 0 - foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) - -If exprOkForSpeculation doesn't look through case expressions, you get 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 - } - -The inner case is redundant, and should be nuked. - -Note [Exhaustive alts] -~~~~~~~~~~~~~~~~~~~~~~ -We might have something like - case x of { - A -> ... - _ -> ...(case x of { B -> ...; C -> ... })... -Here, the inner case is fine, because the A alternative -can't happen, but it's not ok to float the inner case outside -the outer one (even if we know x is evaluated outside), because -then it would be non-exhaustive. See Trac #5453. - -Similarly, this is a valid program (albeit a slightly dodgy one) - let v = case x of { B -> ...; C -> ... } - in case x of - A -> ... - _ -> ...v...v.... -But we don't want to speculate the v binding. - -One could try to be clever, but the easy fix is simpy to regard -a non-exhaustive case as *not* okForSpeculation. - - -Note [dataToTag speculation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is this OK? - f x = let v::Int# = dataToTag# x - in ... -We say "yes", even though 'x' may not be evaluated. Reasons - - * dataToTag#'s strictness means that its argument often will be - evaluated, but FloatOut makes that temporarily untrue - case x of y -> let v = dataToTag# y in ... - --> - case x of y -> let v = dataToTag# x in ... - Note that we look at 'x' instead of 'y' (this is to improve - floating in FloatOut). So Lint complains. - - Moreover, it really *might* improve floating to let the - v-binding float out - - * CorePrep makes sure dataToTag#'s argument is evaluated, just - before code gen. Until then, it's not guaranteed - - -%************************************************************************ -%* * - exprIsHNF, exprIsConLike -%* * -%************************************************************************ - -\begin{code} --- 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 "CoreSyn#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 -\end{code} - -\begin{code} --- | 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 - = is_con v -- Catches nullary constructors, - -- so that [] and () are values, for example - || idArity v > 0 -- Catches (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 - -- 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 (Type _)) = is_hnf_like e - is_hnf_like (App e (Coercion _)) = is_hnf_like e - is_hnf_like (App e a) = app_is_value e [a] - is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us - is_hnf_like _ = False - - -- There is at least one value argument - app_is_value :: CoreExpr -> [CoreArg] -> Bool - app_is_value (Var fun) args - = idArity fun > valArgCount args -- Under-applied function - || is_con fun -- or constructor-like - app_is_value (Tick _ f) as = app_is_value f as - app_is_value (Cast f _) as = app_is_value f as - app_is_value (App f a) as = app_is_value f (a:as) - app_is_value _ _ = False - -{- -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. --} -\end{code} - - -%************************************************************************ -%* * - Instantiating data constructors -%* * -%************************************************************************ - -These InstPat functions go here to avoid circularity between DataCon and Id - -\begin{code} -dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) -dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [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 - -> ([TyVar], [Id]) -- Return instantiated variables --- dataConInstPat arg_fun fss us con inst_tys returns a triple --- (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 = dataConExTyVars 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 = zipOpenTvSubst univ_tvs inst_tys - - -- Make existential type variables, applyingn and extending the substitution - (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst - (zip3 ex_tvs ex_fss ex_uniqs) - - mk_ex_var :: TvSubst -> (TyVar, FastString, Unique) -> (TvSubst, TyVar) - mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubst subst tv (mkTyVarTy new_tv) - , new_tv) - where - new_tv = mkTyVar new_name kind - new_name = mkSysTvName uniq fs - kind = Type.substTy subst (tyVarKind 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 - = mkLocalIdWithInfo name (Type.substTy full_subst ty) info - where - name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan - info | isMarkedStrict str = vanillaIdInfo `setUnfoldingInfo` evaldUnfolding - | otherwise = vanillaIdInfo - -- See Note [Mark evaluated arguments] -\end{code} - -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 -%* * -%************************************************************************ - -\begin{code} --- | 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 (Var v1) (Var v2) = v1==v2 -cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2 -cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2 -cheapEqExpr (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2 - -cheapEqExpr (App f1 a1) (App f2 a2) - = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 - -cheapEqExpr (Cast e1 t1) (Cast e2 t2) - = e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2 - -cheapEqExpr _ _ = False -\end{code} - -\begin{code} -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 _ = True -\end{code} - -\begin{code} -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) = coreEqCoercion2 env co1 co2 - go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 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) = go_tickish 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) - = 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 - - ----------- - go_tickish env (Breakpoint lid lids) (Breakpoint rid rids) - = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids - go_tickish _ l r = l == r -\end{code} - -%************************************************************************ -%* * -\subsection{The size of an expression} -%* * -%************************************************************************ - -\begin{code} -data CoreStats = CS { cs_tm :: Int -- Terms - , cs_ty :: Int -- Types - , cs_co :: Int } -- Coercions - - -instance Outputable CoreStats where - ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) - = braces (sep [ptext (sLit "terms:") <+> intWithCommas i1 <> comma, - ptext (sLit "types:") <+> intWithCommas i2 <> comma, - ptext (sLit "coercions:") <+> intWithCommas i3]) - -plusCS :: CoreStats -> CoreStats -> CoreStats -plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 }) - (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 }) - = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2 } - -zeroCS, oneTM :: CoreStats -zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0 } -oneTM = zeroCS { cs_tm = 1 } - -sumCS :: (a -> CoreStats) -> [a] -> CoreStats -sumCS f = foldr (plusCS . f) zeroCS - -coreBindsStats :: [CoreBind] -> CoreStats -coreBindsStats = sumCS bindStats - -bindStats :: CoreBind -> CoreStats -bindStats (NonRec v r) = bindingStats v r -bindStats (Rec prs) = sumCS (\(v,r) -> bindingStats v r) prs - -bindingStats :: Var -> CoreExpr -> CoreStats -bindingStats v r = bndrStats v `plusCS` exprStats r - -bndrStats :: Var -> CoreStats -bndrStats v = oneTM `plusCS` 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 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 } -\end{code} - - -\begin{code} -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 = foldr ((+) . bindSize) 0 bs - -exprSize :: CoreExpr -> Int --- ^ A measure of the size of the expressions, strictly greater than 0 --- It also forces the expression pretty drastically as a side effect --- Counts *leaves*, not internal nodes. Types and coercions are not counted. -exprSize (Var v) = v `seq` 1 -exprSize (Lit lit) = lit `seq` 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 t as) = seqType t `seq` exprSize e + bndrSize b + 1 + foldr ((+) . altSize) 0 as -exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e -exprSize (Tick n e) = tickSize n + exprSize e -exprSize (Type t) = seqType t `seq` 1 -exprSize (Coercion co) = seqCo co `seq` 1 - -tickSize :: Tickish Id -> Int -tickSize (ProfNote cc _ _) = cc `seq` 1 -tickSize _ = 1 -- the rest are strict - -bndrSize :: Var -> Int -bndrSize b | isTyVar b = seqType (tyVarKind b) `seq` 1 - | otherwise = seqType (idType b) `seq` - megaSeqIdInfo (idInfo b) `seq` - 1 - -bndrsSize :: [Var] -> Int -bndrsSize = sum . map bndrSize - -bindSize :: CoreBind -> Int -bindSize (NonRec b e) = bndrSize b + exprSize e -bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs - -pairSize :: (Var, CoreExpr) -> Int -pairSize (b,e) = bndrSize b + exprSize e - -altSize :: CoreAlt -> Int -altSize (c,bs,e) = c `seq` bndrsSize bs + exprSize e -\end{code} - - -%************************************************************************ -%* * - 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 Trac #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. - -\begin{code} -tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr -tryEtaReduce bndrs body - = go (reverse bndrs) body (mkReflCo Representational (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 (b : bs) (App fun arg) co - | Just co' <- ok_arg b arg co - = go bs fun co' - - go _ _ _ = Nothing -- Failure! - - --------------- - -- Note [Eta reduction conditions] - ok_fun (App fun (Type {})) = ok_fun fun - ok_fun (Cast fun _) = ok_fun fun - 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) - -- See Note [Eta reduction with casted arguments] - ok_arg bndr (Type ty) co - | Just tv <- getTyVar_maybe ty - , bndr == tv = Just (mkForAllCo tv co) - ok_arg bndr (Var v) co - | bndr == v = Just (mkFunCo Representational - (mkReflCo Representational (idType bndr)) co) - ok_arg bndr (Cast (Var v) co_arg) co - | bndr == v = Just (mkFunCo Representational (mkSymCo co_arg) co) - -- The simplifier combines multiple casts into one, - -- so we can have a simple-minded pattern match here - ok_arg _ _ _ = Nothing -\end{code} - -Note [Eta reduction of an eval'd function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Haskell is 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 Trac #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. - -\begin{code} --- | This function is called only on *top-level* right-hand sides. --- Returns @True@ if the RHS can be allocated statically in the output, --- with no thunks involved at all. -rhsIsStatic :: Platform -> (Name -> Bool) -> CoreExpr -> Bool --- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or --- refers to, CAFs; (ii) in CoreToStg to decide whether to put an --- update flag on it and (iii) in DsExpr to decide how to expand --- list literals --- --- The basic idea is that rhsIsStatic returns True only if the RHS is --- (a) a value lambda --- (b) a saturated constructor application with static args --- --- BUT watch out for --- (i) Any cross-DLL references kill static-ness completely --- because they must be 'executed' not statically allocated --- ("DLL" here really only refers to Windows DLLs, on other platforms, --- this is not necessary) --- --- (ii) We treat partial applications as redexes, because in fact we --- make a thunk for them that runs and builds a PAP --- at run-time. The only appliations that are treated as --- static are *saturated* applications of constructors. - --- We used to try to be clever with nested structures like this: --- ys = (:) w ((:) w []) --- on the grounds that CorePrep will flatten ANF-ise it later. --- But supporting this special case made the function much more --- complicated, because the special case only applies if there are no --- enclosing type lambdas: --- ys = /\ a -> Foo (Baz ([] a)) --- Here the nested (Baz []) won't float out to top level in CorePrep. --- --- But in fact, even without -O, nested structures at top level are --- flattened by the simplifier, so we don't need to be super-clever here. --- --- Examples --- --- f = \x::Int. x+7 TRUE --- p = (True,False) TRUE --- --- d = (fst p, False) FALSE because there's a redex inside --- (this particular one doesn't happen but...) --- --- h = D# (1.0## /## 2.0##) FALSE (redex again) --- n = /\a. Nil a TRUE --- --- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex) --- --- --- This is a bit like CoreUtils.exprIsHNF, with the following differences: --- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) --- --- b) (C x xs), where C is a contructor is updatable if the application is --- dynamic --- --- c) don't look through unfolding of f in (f x). - -rhsIsStatic platform is_dynamic_name rhs = is_static False rhs - where - is_static :: Bool -- True <=> in a constructor argument; must be atomic - -> CoreExpr -> Bool - - is_static False (Lam b e) = isRuntimeVar b || is_static False e - is_static in_arg (Tick n e) = not (tickishIsCode n) - && is_static in_arg e - is_static in_arg (Cast e _) = is_static in_arg e - is_static _ (Coercion {}) = True -- Behaves just like a literal - is_static _ (Lit (LitInteger {})) = False - is_static _ (Lit (MachLabel {})) = False - is_static _ (Lit _) = True - -- A MachLabel (foreign import "&foo") in an argument - -- prevents a constructor application from being static. The - -- reason is that it might give rise to unresolvable symbols - -- in the object file: under Linux, references to "weak" - -- symbols from the data segment give rise to "unresolvable - -- relocation" errors at link time This might be due to a bug - -- in the linker, but we'll work around it here anyway. - -- SDM 24/2/2004 - - is_static in_arg other_expr = go other_expr 0 - where - go (Var f) n_val_args - | (platformOS platform /= OSMinGW32) || - not (is_dynamic_name (idName f)) - = saturated_data_con f n_val_args - || (in_arg && n_val_args == 0) - -- A naked un-applied variable is *not* deemed a static RHS - -- E.g. f = g - -- Reason: better to update so that the indirection gets shorted - -- out, and the true value will be seen - -- NB: if you change this, you'll break the invariant that THUNK_STATICs - -- are always updatable. If you do so, make sure that non-updatable - -- ones have enough space for their static link field! - - go (App f a) n_val_args - | isTypeArg a = go f n_val_args - | not in_arg && is_static True a = go f (n_val_args + 1) - -- The (not in_arg) checks that we aren't in a constructor argument; - -- if we are, we don't allow (value) applications of any sort - -- - -- NB. In case you wonder, args are sometimes not atomic. eg. - -- x = D# (1.0## /## 2.0##) - -- can't float because /## can fail. - - go (Tick n f) n_val_args = not (tickishIsCode n) && go f n_val_args - go (Cast e _) n_val_args = go e n_val_args - go _ _ = False - - saturated_data_con f n_val_args - = case isDataConWorkId_maybe f of - Just dc -> n_val_args == dataConRepArity dc - Nothing -> False -\end{code} diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs new file mode 100644 index 0000000000..6905641f56 --- /dev/null +++ b/compiler/coreSyn/MkCore.hs @@ -0,0 +1,774 @@ +{-# LANGUAGE CPP #-} + +-- | Handy functions for creating much Core syntax +module MkCore ( + -- * Constructing normal syntax + mkCoreLet, mkCoreLets, + mkCoreApp, mkCoreApps, mkCoreConApps, + mkCoreLams, mkWildCase, mkIfThenElse, + mkWildValBinder, mkWildEvBinder, + sortQuantVars, castBottomExpr, + + -- * Constructing boxed literals + mkWordExpr, mkWordExprWord, + mkIntExpr, mkIntExprInt, + mkIntegerExpr, + mkFloatExpr, mkDoubleExpr, + mkCharExpr, mkStringExpr, mkStringExprFS, + + -- * Floats + FloatBind(..), wrapFloat, + + -- * Constructing equality evidence boxes + mkEqBox, + + -- * Constructing general big tuples + -- $big_tuples + mkChunkified, + + -- * Constructing small tuples + mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, + + -- * Constructing big tuples + mkBigCoreVarTup, mkBigCoreVarTupTy, + mkBigCoreTup, mkBigCoreTupTy, + + -- * Deconstructing small tuples + mkSmallTupleSelector, mkSmallTupleCase, + + -- * Deconstructing big tuples + mkTupleSelector, mkTupleCase, + + -- * Constructing list expressions + mkNilExpr, mkConsExpr, mkListExpr, + mkFoldrExpr, mkBuildExpr, + + -- * Error Ids + mkRuntimeErrorApp, mkImpossibleExpr, errorIds, + rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, + uNDEFINED_ID, undefinedName + ) where + +#include "HsVersions.h" + +import Id +import Var ( EvVar, setTyVarUnique ) + +import CoreSyn +import CoreUtils ( exprType, needsCaseBinding, bindNonRec ) +import Literal +import HscTypes + +import TysWiredIn +import PrelNames + +import TcType ( mkSigmaTy ) +import Type +import Coercion +import TysPrim +import DataCon ( DataCon, dataConWorkId ) +import IdInfo ( vanillaIdInfo, setStrictnessInfo, + setArityInfo ) +import Demand +import Name hiding ( varName ) +import Outputable +import FastString +import UniqSupply +import BasicTypes +import Util +import Pair +import Constants +import DynFlags + +import Data.Char ( ord ) +import Data.List +import Data.Ord +#if __GLASGOW_HASKELL__ < 709 +import Data.Word ( Word ) +#endif + +infixl 4 `mkCoreApp`, `mkCoreApps` + +{- +************************************************************************ +* * +\subsection{Basic CoreSyn construction} +* * +************************************************************************ +-} + +sortQuantVars :: [Var] -> [Var] +-- Sort the variables (KindVars, TypeVars, and Ids) +-- into order: Kind, then Type, then Id +sortQuantVars = sortBy (comparing withCategory) + where + withCategory v = (category v, v) + category :: Var -> Int + category v + | isKindVar v = 1 + | isTyVar v = 2 + | otherwise = 3 + +-- | Bind a binding group over an expression, using a @let@ or @case@ as +-- appropriate (see "CoreSyn#let_app_invariant") +mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr +mkCoreLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant] + | needsCaseBinding (idType bndr) rhs + = Case rhs bndr (exprType body) [(DEFAULT,[],body)] +mkCoreLet bind body + = Let bind body + +-- | 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 one expression +-- to the other +mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr +-- Respects the let/app invariant by building a case expression where necessary +-- See CoreSyn Note [CoreSyn let/app invariant] +mkCoreApp fun (Type ty) = App fun (Type ty) +mkCoreApp fun (Coercion co) = App fun (Coercion co) +mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg ) + mk_val_app fun arg arg_ty res_ty + where + fun_ty = exprType fun + (arg_ty, res_ty) = splitFunTy fun_ty + +-- | 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 CoreSyn Note [CoreSyn let/app invariant] +mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr +-- Slightly more efficient version of (foldl mkCoreApp) +mkCoreApps orig_fun orig_args + = go orig_fun (exprType orig_fun) orig_args + where + go fun _ [] = fun + go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args + go fun fun_ty (Coercion co : args) = go (App fun (Coercion co)) (applyCo fun_ty co) args + go fun fun_ty (arg : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun + $$ ppr orig_args ) + go (mk_val_app fun arg arg_ty res_ty) res_ty args + where + (arg_ty, res_ty) = splitFunTy fun_ty + +-- | 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 + +mk_val_app :: 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 [CoreSyn let/app invariant] +mk_val_app fun arg arg_ty res_ty + | not (needsCaseBinding arg_ty arg) + = App fun arg -- The vastly common case + + | otherwise + = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] + where + arg_id = mkWildValBinder arg_ty + -- Lots of shadowing, but it doesn't matter, + -- because 'fun ' should not have a free wild-id + -- + -- This is Dangerous. But this is the only place we play this + -- game, mk_val_app returns an expression that does not have + -- have a free wild-id. So the only thing that can go wrong + -- is if you take apart this case expression, and pass a + -- fragmet of it as the fun part of a 'mk_val_app'. + +----------- +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 = mkLocalId wildCardName ty + +mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr +-- Make a case expression whose case binder is unused +-- The alts should not have any occurrences of WildId +mkWildCase scrut scrut_ty res_ty alts + = Case scrut (mkWildValBinder scrut_ty) res_ty alts + +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 CoreSyn +castBottomExpr e res_ty + | e_ty `eqType` res_ty = e + | otherwise = Case e (mkWildValBinder e_ty) res_ty [] + where + e_ty = exprType e + +{- +The functions from this point don't really do anything cleverer than +their counterparts in CoreSyn, but they are here for consistency +-} + +-- | 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 + +{- +************************************************************************ +* * +\subsection{Making literals} +* * +************************************************************************ +-} + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@ +mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int +mkIntExpr dflags i = mkConApp 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 = mkConApp 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 = mkConApp wordDataCon [mkWordLit dflags w] + +-- | Create a 'CoreExpr' which will evaluate to the given @Word@ +mkWordExprWord :: DynFlags -> Word -> CoreExpr +mkWordExprWord dflags w = mkConApp 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 @Float@ +mkFloatExpr :: Float -> CoreExpr +mkFloatExpr f = mkConApp floatDataCon [mkFloatLitFloat f] + +-- | Create a 'CoreExpr' which will evaluate to the given @Double@ +mkDoubleExpr :: Double -> CoreExpr +mkDoubleExpr d = mkConApp doubleDataCon [mkDoubleLitDouble d] + + +-- | Create a 'CoreExpr' which will evaluate to the given @Char@ +mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int +mkCharExpr c = mkConApp 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 str + | nullFS str + = return (mkNilExpr charTy) + + | all safeChar chars + = do unpack_id <- lookupId unpackCStringName + return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str)))) + + | otherwise + = do unpack_id <- lookupId unpackCStringUtf8Name + return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str)))) + + where + chars = unpackFS str + safeChar c = ord c >= 1 && ord c <= 0x7F + +-- This take a ~# b (or a ~# R b) and returns a ~ b (or Coercible a b) +mkEqBox :: Coercion -> CoreExpr +mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ ppr (typeKind ty1) $$ ppr (typeKind ty2) ) + Var (dataConWorkId datacon) `mkTyApps` [k, ty1, ty2] `App` Coercion co + where (Pair ty1 ty2, role) = coercionKindRole co + k = typeKind ty1 + datacon = case role of + Nominal -> eqBoxDataCon + Representational -> coercibleDataCon + Phantom -> pprPanic "mkEqBox does not support boxing phantom coercions" + (ppr co) + +{- +************************************************************************ +* * +\subsection{Tuple constructors} +* * +************************************************************************ +-} + +-- $big_tuples +-- #big_tuples# +-- +-- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but +-- we might concievably want to build such a massive tuple as part of the +-- output of a desugaring stage (notably that for list comprehensions). +-- +-- We call tuples above this size \"big tuples\", and emulate them by +-- creating and pattern matching on >nested< tuples that are expressible +-- by GHC. +-- +-- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) +-- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any +-- construction to be big. +-- +-- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector' +-- and 'mkTupleCase' functions to do all your work with tuples you should be +-- fine, and not have to worry about the arity limitation at all. + +-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon +mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' + -> [a] -- ^ Possible \"big\" list of things to construct from + -> a -- ^ Constructed thing made possible by recursive decomposition +mkChunkified small_tuple as = mk_big_tuple (chunkify as) + where + -- Each sub-list is short enough to fit in a tuple + mk_big_tuple [as] = small_tuple as + mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) + +chunkify :: [a] -> [[a]] +-- ^ Split a list into lists that are small enough to have a corresponding +-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' +-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists +chunkify xs + | n_xs <= mAX_TUPLE_SIZE = [xs] + | otherwise = split xs + where + n_xs = length xs + split [] = [] + split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) + +{- +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. +-} + +-- | Build a small tuple holding the specified variables +mkCoreVarTup :: [Id] -> CoreExpr +mkCoreVarTup ids = mkCoreTup (map Var ids) + +-- | Bulid the type of a small tuple that holds the specified variables +mkCoreVarTupTy :: [Id] -> Type +mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) + +-- | Build a small tuple holding the specified expressions +mkCoreTup :: [CoreExpr] -> CoreExpr +mkCoreTup [] = Var unitDataConId +mkCoreTup [c] = c +mkCoreTup cs = mkConApp (tupleCon BoxedTuple (length cs)) + (map (Type . exprType) cs ++ cs) + +-- | Build a big tuple holding the specified variables +mkBigCoreVarTup :: [Id] -> CoreExpr +mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) + +-- | Build the type of a big tuple that holds the specified variables +mkBigCoreVarTupTy :: [Id] -> Type +mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) + +-- | Build a big tuple holding the specified expressions +mkBigCoreTup :: [CoreExpr] -> CoreExpr +mkBigCoreTup = mkChunkified mkCoreTup + +-- | Build the type of a big tuple that holds the specified type of thing +mkBigCoreTupTy :: [Type] -> Type +mkBigCoreTupTy = mkChunkified mkBoxedTupleTy + +{- +************************************************************************ +* * + Floats +* * +************************************************************************ +-} + +data FloatBind + = FloatLet CoreBind + | FloatCase CoreExpr Id AltCon [Var] + -- case e of y { C ys -> ... } + -- See Note [Floating cases] in SetLevels + +instance Outputable FloatBind where + ppr (FloatLet b) = ptext (sLit "LET") <+> ppr b + ppr (FloatCase e b c bs) = hang (ptext (sLit "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 = Case e b (exprType body) [(con, bs, body)] + +{- +************************************************************************ +* * +\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 :: [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 ] + +-- | 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 :: [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 +mkSmallTupleSelector vars the_var scrut_var scrut + = ASSERT( notNull vars ) + Case scrut scrut_var (idType the_var) + [(DataAlt (tupleCon BoxedTuple (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 (tupleCon BoxedTuple (length vars)), vars, body)] + +{- +************************************************************************ +* * +\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 = mkConApp nilDataCon [Type ty] + +-- | Makes a list @(:)@ for lists of the specified type +mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr +mkConsExpr ty hd tl = mkConApp 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 :: (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 = mkFunTys [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) + +{- +************************************************************************ +* * + 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 res_ty, err_string] + where + err_string = Lit (mkMachString 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 + = [ eRROR_ID, -- This one isn't used anywhere else in the compiler + -- But we still need it in wiredInIds so that when GHC + -- compiles a program that mentions 'error' we don't + -- import its type from the interface file; we just get + -- the Id defined here. Which has an 'open-tyvar' type. + + uNDEFINED_ID, -- Ditto for 'undefined'. The big deal is to give it + -- an 'open-tyvar' type. + + rUNTIME_ERROR_ID, + iRREFUT_PAT_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 ] + +recSelErrorName, runtimeErrorName, absentErrorName :: Name +irrefutPatErrorName, recConErrorName, patErrorName :: Name +nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name + +recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID +absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID +runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID +irrefutPatErrorName = err_nm "irrefutPatError" irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID +recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = err_nm "patError" patErrorIdKey pAT_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, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id +pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id +aBSENT_ERROR_ID :: Id +rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName +rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName +iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName +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 +aBSENT_ERROR_ID = mkRuntimeErrorId absentErrorName + +mkRuntimeErrorId :: Name -> Id +mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy + +runtimeErrorTy :: Type +-- The runtime error Ids take a UTF8-encoded string as argument +runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) + +errorName :: Name +errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID + +eRROR_ID :: Id +eRROR_ID = pc_bottoming_Id1 errorName errorTy + +errorTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] +errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy) + +undefinedName :: Name +undefinedName = mkWiredInIdName gHC_ERR (fsLit "undefined") undefinedKey uNDEFINED_ID + +uNDEFINED_ID :: Id +uNDEFINED_ID = pc_bottoming_Id0 undefinedName undefinedTy + +undefinedTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] +undefinedTy = mkSigmaTy [openAlphaTyVar] [] openAlphaTy + +{- +Note [Error and friends have an "open-tyvar" forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'error' and 'undefined' have types + error :: forall (a::OpenKind). String -> a + undefined :: forall (a::OpenKind). a +Notice the 'OpenKind' (manifested as openAlphaTyVar in the code). This ensures that +"error" can be instantiated at + * unboxed as well as boxed types + * polymorphic types +This is OK because it never returns, so the return type is irrelevant. +See Note [OpenTypeKind accepts foralls] in TcUnify. + + +************************************************************************ +* * +\subsection{Utilities} +* * +************************************************************************ +-} + +pc_bottoming_Id1 :: Name -> Type -> Id +-- Function of arity 1, which diverges after being given one argument +pc_bottoming_Id1 name ty + = mkVanillaGlobalWithInfo name ty bottoming_info + where + bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig + `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] botRes + -- These "bottom" out, no matter what their arguments + +pc_bottoming_Id0 :: Name -> Type -> Id +-- Same but arity zero +pc_bottoming_Id0 name ty + = mkVanillaGlobalWithInfo name ty bottoming_info + where + bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig + strict_sig = mkClosedStrictSig [] botRes diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs deleted file mode 100644 index 81f05338b3..0000000000 --- a/compiler/coreSyn/MkCore.lhs +++ /dev/null @@ -1,792 +0,0 @@ -\begin{code} -{-# LANGUAGE CPP #-} - --- | Handy functions for creating much Core syntax -module MkCore ( - -- * Constructing normal syntax - mkCoreLet, mkCoreLets, - mkCoreApp, mkCoreApps, mkCoreConApps, - mkCoreLams, mkWildCase, mkIfThenElse, - mkWildValBinder, mkWildEvBinder, - sortQuantVars, castBottomExpr, - - -- * Constructing boxed literals - mkWordExpr, mkWordExprWord, - mkIntExpr, mkIntExprInt, - mkIntegerExpr, - mkFloatExpr, mkDoubleExpr, - mkCharExpr, mkStringExpr, mkStringExprFS, - - -- * Floats - FloatBind(..), wrapFloat, - - -- * Constructing equality evidence boxes - mkEqBox, - - -- * Constructing general big tuples - -- $big_tuples - mkChunkified, - - -- * Constructing small tuples - mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, - - -- * Constructing big tuples - mkBigCoreVarTup, mkBigCoreVarTupTy, - mkBigCoreTup, mkBigCoreTupTy, - - -- * Deconstructing small tuples - mkSmallTupleSelector, mkSmallTupleCase, - - -- * Deconstructing big tuples - mkTupleSelector, mkTupleCase, - - -- * Constructing list expressions - mkNilExpr, mkConsExpr, mkListExpr, - mkFoldrExpr, mkBuildExpr, - - -- * Error Ids - mkRuntimeErrorApp, mkImpossibleExpr, errorIds, - rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, - nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, - uNDEFINED_ID, undefinedName - ) where - -#include "HsVersions.h" - -import Id -import Var ( EvVar, setTyVarUnique ) - -import CoreSyn -import CoreUtils ( exprType, needsCaseBinding, bindNonRec ) -import Literal -import HscTypes - -import TysWiredIn -import PrelNames - -import TcType ( mkSigmaTy ) -import Type -import Coercion -import TysPrim -import DataCon ( DataCon, dataConWorkId ) -import IdInfo ( vanillaIdInfo, setStrictnessInfo, - setArityInfo ) -import Demand -import Name hiding ( varName ) -import Outputable -import FastString -import UniqSupply -import BasicTypes -import Util -import Pair -import Constants -import DynFlags - -import Data.Char ( ord ) -import Data.List -import Data.Ord -#if __GLASGOW_HASKELL__ < 709 -import Data.Word ( Word ) -#endif - -infixl 4 `mkCoreApp`, `mkCoreApps` -\end{code} - -%************************************************************************ -%* * -\subsection{Basic CoreSyn construction} -%* * -%************************************************************************ - -\begin{code} -sortQuantVars :: [Var] -> [Var] --- Sort the variables (KindVars, TypeVars, and Ids) --- into order: Kind, then Type, then Id -sortQuantVars = sortBy (comparing withCategory) - where - withCategory v = (category v, v) - category :: Var -> Int - category v - | isKindVar v = 1 - | isTyVar v = 2 - | otherwise = 3 - --- | Bind a binding group over an expression, using a @let@ or @case@ as --- appropriate (see "CoreSyn#let_app_invariant") -mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr -mkCoreLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant] - | needsCaseBinding (idType bndr) rhs - = Case rhs bndr (exprType body) [(DEFAULT,[],body)] -mkCoreLet bind body - = Let bind body - --- | 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 one expression --- to the other -mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr --- Respects the let/app invariant by building a case expression where necessary --- See CoreSyn Note [CoreSyn let/app invariant] -mkCoreApp fun (Type ty) = App fun (Type ty) -mkCoreApp fun (Coercion co) = App fun (Coercion co) -mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg ) - mk_val_app fun arg arg_ty res_ty - where - fun_ty = exprType fun - (arg_ty, res_ty) = splitFunTy fun_ty - --- | 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 CoreSyn Note [CoreSyn let/app invariant] -mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr --- Slightly more efficient version of (foldl mkCoreApp) -mkCoreApps orig_fun orig_args - = go orig_fun (exprType orig_fun) orig_args - where - go fun _ [] = fun - go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args - go fun fun_ty (Coercion co : args) = go (App fun (Coercion co)) (applyCo fun_ty co) args - go fun fun_ty (arg : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun - $$ ppr orig_args ) - go (mk_val_app fun arg arg_ty res_ty) res_ty args - where - (arg_ty, res_ty) = splitFunTy fun_ty - --- | 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 - -mk_val_app :: 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 [CoreSyn let/app invariant] -mk_val_app fun arg arg_ty res_ty - | not (needsCaseBinding arg_ty arg) - = App fun arg -- The vastly common case - - | otherwise - = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] - where - arg_id = mkWildValBinder arg_ty - -- Lots of shadowing, but it doesn't matter, - -- because 'fun ' should not have a free wild-id - -- - -- This is Dangerous. But this is the only place we play this - -- game, mk_val_app returns an expression that does not have - -- have a free wild-id. So the only thing that can go wrong - -- is if you take apart this case expression, and pass a - -- fragmet of it as the fun part of a 'mk_val_app'. - ------------ -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 = mkLocalId wildCardName ty - -mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr --- Make a case expression whose case binder is unused --- The alts should not have any occurrences of WildId -mkWildCase scrut scrut_ty res_ty alts - = Case scrut (mkWildValBinder scrut_ty) res_ty alts - -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 CoreSyn -castBottomExpr e res_ty - | e_ty `eqType` res_ty = e - | otherwise = Case e (mkWildValBinder e_ty) res_ty [] - where - e_ty = exprType e -\end{code} - -The functions from this point don't really do anything cleverer than -their counterparts in CoreSyn, but they are here for consistency - -\begin{code} --- | 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 -\end{code} - -%************************************************************************ -%* * -\subsection{Making literals} -%* * -%************************************************************************ - -\begin{code} --- | Create a 'CoreExpr' which will evaluate to the given @Int@ -mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int -mkIntExpr dflags i = mkConApp 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 = mkConApp 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 = mkConApp wordDataCon [mkWordLit dflags w] - --- | Create a 'CoreExpr' which will evaluate to the given @Word@ -mkWordExprWord :: DynFlags -> Word -> CoreExpr -mkWordExprWord dflags w = mkConApp 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 @Float@ -mkFloatExpr :: Float -> CoreExpr -mkFloatExpr f = mkConApp floatDataCon [mkFloatLitFloat f] - --- | Create a 'CoreExpr' which will evaluate to the given @Double@ -mkDoubleExpr :: Double -> CoreExpr -mkDoubleExpr d = mkConApp doubleDataCon [mkDoubleLitDouble d] - - --- | Create a 'CoreExpr' which will evaluate to the given @Char@ -mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int -mkCharExpr c = mkConApp 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 str - | nullFS str - = return (mkNilExpr charTy) - - | all safeChar chars - = do unpack_id <- lookupId unpackCStringName - return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str)))) - - | otherwise - = do unpack_id <- lookupId unpackCStringUtf8Name - return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str)))) - - where - chars = unpackFS str - safeChar c = ord c >= 1 && ord c <= 0x7F -\end{code} - -\begin{code} - --- This take a ~# b (or a ~# R b) and returns a ~ b (or Coercible a b) -mkEqBox :: Coercion -> CoreExpr -mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ ppr (typeKind ty1) $$ ppr (typeKind ty2) ) - Var (dataConWorkId datacon) `mkTyApps` [k, ty1, ty2] `App` Coercion co - where (Pair ty1 ty2, role) = coercionKindRole co - k = typeKind ty1 - datacon = case role of - Nominal -> eqBoxDataCon - Representational -> coercibleDataCon - Phantom -> pprPanic "mkEqBox does not support boxing phantom coercions" - (ppr co) -\end{code} - -%************************************************************************ -%* * -\subsection{Tuple constructors} -%* * -%************************************************************************ - -\begin{code} - --- $big_tuples --- #big_tuples# --- --- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but --- we might concievably want to build such a massive tuple as part of the --- output of a desugaring stage (notably that for list comprehensions). --- --- We call tuples above this size \"big tuples\", and emulate them by --- creating and pattern matching on >nested< tuples that are expressible --- by GHC. --- --- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) --- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any --- construction to be big. --- --- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector' --- and 'mkTupleCase' functions to do all your work with tuples you should be --- fine, and not have to worry about the arity limitation at all. - --- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon -mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' - -> [a] -- ^ Possible \"big\" list of things to construct from - -> a -- ^ Constructed thing made possible by recursive decomposition -mkChunkified small_tuple as = mk_big_tuple (chunkify as) - where - -- Each sub-list is short enough to fit in a tuple - mk_big_tuple [as] = small_tuple as - mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) - -chunkify :: [a] -> [[a]] --- ^ Split a list into lists that are small enough to have a corresponding --- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' --- But there may be more than 'mAX_TUPLE_SIZE' sub-lists -chunkify xs - | n_xs <= mAX_TUPLE_SIZE = [xs] - | otherwise = split xs - where - n_xs = length xs - split [] = [] - split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) - -\end{code} - -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. - -\begin{code} - --- | Build a small tuple holding the specified variables -mkCoreVarTup :: [Id] -> CoreExpr -mkCoreVarTup ids = mkCoreTup (map Var ids) - --- | Bulid the type of a small tuple that holds the specified variables -mkCoreVarTupTy :: [Id] -> Type -mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) - --- | Build a small tuple holding the specified expressions -mkCoreTup :: [CoreExpr] -> CoreExpr -mkCoreTup [] = Var unitDataConId -mkCoreTup [c] = c -mkCoreTup cs = mkConApp (tupleCon BoxedTuple (length cs)) - (map (Type . exprType) cs ++ cs) - --- | Build a big tuple holding the specified variables -mkBigCoreVarTup :: [Id] -> CoreExpr -mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) - --- | Build the type of a big tuple that holds the specified variables -mkBigCoreVarTupTy :: [Id] -> Type -mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) - --- | Build a big tuple holding the specified expressions -mkBigCoreTup :: [CoreExpr] -> CoreExpr -mkBigCoreTup = mkChunkified mkCoreTup - --- | Build the type of a big tuple that holds the specified type of thing -mkBigCoreTupTy :: [Type] -> Type -mkBigCoreTupTy = mkChunkified mkBoxedTupleTy -\end{code} - - -%************************************************************************ -%* * - Floats -%* * -%************************************************************************ - -\begin{code} -data FloatBind - = FloatLet CoreBind - | FloatCase CoreExpr Id AltCon [Var] - -- case e of y { C ys -> ... } - -- See Note [Floating cases] in SetLevels - -instance Outputable FloatBind where - ppr (FloatLet b) = ptext (sLit "LET") <+> ppr b - ppr (FloatCase e b c bs) = hang (ptext (sLit "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 = Case e b (exprType body) [(con, bs, body)] -\end{code} - -%************************************************************************ -%* * -\subsection{Tuple destructors} -%* * -%************************************************************************ - -\begin{code} --- | 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 :: [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 ] -\end{code} - -\begin{code} --- | 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 :: [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 -mkSmallTupleSelector vars the_var scrut_var scrut - = ASSERT( notNull vars ) - Case scrut scrut_var (idType the_var) - [(DataAlt (tupleCon BoxedTuple (length vars)), vars, Var the_var)] -\end{code} - -\begin{code} --- | 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') -\end{code} - -\begin{code} --- | 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 (tupleCon BoxedTuple (length vars)), vars, body)] -\end{code} - -%************************************************************************ -%* * -\subsection{Common list manipulation expressions} -%* * -%************************************************************************ - -Call the constructor Ids when building explicit lists, so that they -interact well with rules. - -\begin{code} --- | Makes a list @[]@ for lists of the specified type -mkNilExpr :: Type -> CoreExpr -mkNilExpr ty = mkConApp nilDataCon [Type ty] - --- | Makes a list @(:)@ for lists of the specified type -mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr -mkConsExpr ty hd tl = mkConApp 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 :: (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 = mkFunTys [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) -\end{code} - - -%************************************************************************ -%* * - Error expressions -%* * -%************************************************************************ - -\begin{code} -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 res_ty, err_string] - where - err_string = Lit (mkMachString err_msg) - -mkImpossibleExpr :: Type -> CoreExpr -mkImpossibleExpr res_ty - = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" -\end{code} - -%************************************************************************ -%* * - 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. - -\begin{code} -errorIds :: [Id] -errorIds - = [ eRROR_ID, -- This one isn't used anywhere else in the compiler - -- But we still need it in wiredInIds so that when GHC - -- compiles a program that mentions 'error' we don't - -- import its type from the interface file; we just get - -- the Id defined here. Which has an 'open-tyvar' type. - - uNDEFINED_ID, -- Ditto for 'undefined'. The big deal is to give it - -- an 'open-tyvar' type. - - rUNTIME_ERROR_ID, - iRREFUT_PAT_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 ] - -recSelErrorName, runtimeErrorName, absentErrorName :: Name -irrefutPatErrorName, recConErrorName, patErrorName :: Name -nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name - -recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID -absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID -runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID -irrefutPatErrorName = err_nm "irrefutPatError" irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID -recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID -patErrorName = err_nm "patError" patErrorIdKey pAT_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, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id -pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id -aBSENT_ERROR_ID :: Id -rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName -rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName -iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName -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 -aBSENT_ERROR_ID = mkRuntimeErrorId absentErrorName - -mkRuntimeErrorId :: Name -> Id -mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy - -runtimeErrorTy :: Type --- The runtime error Ids take a UTF8-encoded string as argument -runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) -\end{code} - -\begin{code} -errorName :: Name -errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID - -eRROR_ID :: Id -eRROR_ID = pc_bottoming_Id1 errorName errorTy - -errorTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] -errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy) - -undefinedName :: Name -undefinedName = mkWiredInIdName gHC_ERR (fsLit "undefined") undefinedKey uNDEFINED_ID - -uNDEFINED_ID :: Id -uNDEFINED_ID = pc_bottoming_Id0 undefinedName undefinedTy - -undefinedTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] -undefinedTy = mkSigmaTy [openAlphaTyVar] [] openAlphaTy -\end{code} - -Note [Error and friends have an "open-tyvar" forall] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'error' and 'undefined' have types - error :: forall (a::OpenKind). String -> a - undefined :: forall (a::OpenKind). a -Notice the 'OpenKind' (manifested as openAlphaTyVar in the code). This ensures that -"error" can be instantiated at - * unboxed as well as boxed types - * polymorphic types -This is OK because it never returns, so the return type is irrelevant. -See Note [OpenTypeKind accepts foralls] in TcUnify. - - -%************************************************************************ -%* * -\subsection{Utilities} -%* * -%************************************************************************ - -\begin{code} -pc_bottoming_Id1 :: Name -> Type -> Id --- Function of arity 1, which diverges after being given one argument -pc_bottoming_Id1 name ty - = mkVanillaGlobalWithInfo name ty bottoming_info - where - bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig - `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] botRes - -- These "bottom" out, no matter what their arguments - -pc_bottoming_Id0 :: Name -> Type -> Id --- Same but arity zero -pc_bottoming_Id0 name ty - = mkVanillaGlobalWithInfo name ty bottoming_info - where - bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig - strict_sig = mkClosedStrictSig [] botRes -\end{code} diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs new file mode 100644 index 0000000000..acc6c79fa1 --- /dev/null +++ b/compiler/coreSyn/PprCore.hs @@ -0,0 +1,527 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +Printing of Core syntax +-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module PprCore ( + pprCoreExpr, pprParendExpr, + pprCoreBinding, pprCoreBindings, pprCoreAlt, + pprRules + ) where + +import CoreSyn +import Literal( pprLiteral ) +import Name( pprInfixName, pprPrefixName ) +import Var +import Id +import IdInfo +import Demand +import DataCon +import TyCon +import Type +import Coercion +import DynFlags +import BasicTypes +import Util +import Outputable +import FastString + +{- +************************************************************************ +* * +\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 +pprCoreBinding = pprTopBind + +instance OutputableBndr b => Outputable (Bind b) where + ppr bind = ppr_bind bind + +instance OutputableBndr b => Outputable (Expr b) where + ppr expr = pprCoreExpr expr + +{- +************************************************************************ +* * +\subsection{The guts} +* * +************************************************************************ +-} + +pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc +pprTopBinds binds = vcat (map pprTopBind binds) + +pprTopBind :: OutputableBndr a => Bind a -> SDoc +pprTopBind (NonRec binder expr) + = ppr_binding (binder,expr) $$ blankLine + +pprTopBind (Rec []) + = ptext (sLit "Rec { }") +pprTopBind (Rec (b:bs)) + = vcat [ptext (sLit "Rec {"), + ppr_binding b, + vcat [blankLine $$ ppr_binding b | b <- bs], + ptext (sLit "end Rec }"), + blankLine] + +ppr_bind :: OutputableBndr b => Bind b -> SDoc + +ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr) +ppr_bind (Rec binds) = vcat (map pp binds) + where + pp bind = ppr_binding bind <> semi + +ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc +ppr_binding (val_bdr, expr) + = pprBndr LetBind val_bdr $$ + hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr) + +pprParendExpr expr = ppr_expr parens expr +pprCoreExpr expr = ppr_expr noParens expr + +noParens :: SDoc -> SDoc +noParens pp = pp + +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 _ (Var name) = ppr name +ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Weird +ppr_expr add_par (Coercion co) = add_par (ptext (sLit "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, + ptext (sLit "`cast`") <+> pprCo co] + where + pprCo co = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressCoercions dflags + then ptext (sLit "...") + else parens $ + sep [ppr co, dcolon <+> ppr (coercionType co)] + + +ppr_expr add_par expr@(Lam _ _) + = let + (bndrs, body) = collectBinders expr + in + add_par $ + hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (pprCoreExpr body) + +ppr_expr add_par expr@(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 = sep (punctuate comma (map pprCoreExpr val_args)) + 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 && isTupleTyCon tc + -> tupleParens (tupleTyConSort tc) pp_tup_args + where + tc = dataConTyCon dc + saturated = val_args `lengthIs` idArity f + + _ -> add_par (hang (ppr f) 2 pp_args) + + _ -> add_par (hang (pprParendExpr fun) 2 pp_args) + } + +ppr_expr add_par (Case expr var ty [(con,args,rhs)]) + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PprCaseAsLet dflags + then add_par $ -- See Note [Print case as let] + sep [ sep [ ptext (sLit "let! {") + <+> ppr_case_pat con args + <+> ptext (sLit "~") + <+> ppr_bndr var + , ptext (sLit "<-") <+> ppr_expr id expr + <+> ptext (sLit "} in") ] + , pprCoreExpr rhs + ] + else add_par $ + sep [sep [ptext (sLit "case") <+> pprCoreExpr expr, + ifPprDebug (braces (ppr ty)), + sep [ptext (sLit "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 [ptext (sLit "case") + <+> pprCoreExpr expr + <+> ifPprDebug (braces (ppr ty)), + ptext (sLit "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 [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], + nest 2 (pprCoreExpr rhs), + ptext (sLit "} in"), + pprCoreExpr body ] + +ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) + = add_par + (hang (ptext (sLit "let {")) + 2 (hsep [ppr_binding (val_bdr,rhs), + ptext (sLit "} in")]) + $$ + pprCoreExpr expr) +-} + +-- General case (recursive case, too) +ppr_expr add_par (Let bind expr) + = add_par $ + sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")), + pprCoreExpr expr] + where + keyword = case bind of + Rec _ -> (sLit "letrec {") + NonRec _ _ -> (sLit "let {") + +ppr_expr add_par (Tick tickish expr) + = 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 + | isTupleTyCon tc + = tupleParens (tupleTyConSort tc) (hsep (punctuate comma (map ppr_bndr args))) + where + ppr_bndr = pprBndr CaseBind + tc = dataConTyCon dc + +ppr_case_pat con args + = ppr con <+> (fsep (map ppr_bndr args)) + where + ppr_bndr = pprBndr CaseBind + + +-- | Pretty print the argument in a function application. +pprArg :: OutputableBndr a => Expr a -> SDoc +pprArg (Type ty) + = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressTypeApplications dflags + then empty + else ptext (sLit "@") <+> pprParendType ty +pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo 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. +-} + +instance OutputableBndr Var where + pprBndr = pprCoreBinder + pprInfixOcc = pprInfixName . varName + pprPrefixOcc = pprPrefixName . varName + +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 = ptext (sLit "@") <+> 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 + = sdocWithDynFlags $ \dflags -> + case () of + _ + | 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 + + | suppress_sigs dflags -> pprUntypedBinder var + + | isTyVar var -> parens (pprKindedTyVarBndr var) + + | otherwise -> parens (hang (pprIdBndr var) + 2 (vcat [ dcolon <+> pprType (idType var) + , pp_unf])) + where + suppress_sigs = gopt Opt_SuppressTypeSignatures + + unf_info = unfoldingInfo (idInfo var) + pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info + | otherwise = empty + +pprTypedLetBinder :: Var -> SDoc +-- Print binder with a type or kind signature (not paren'd) +pprTypedLetBinder binder + = sdocWithDynFlags $ \dflags -> + case () of + _ + | isTyVar binder -> pprKindedTyVarBndr binder + | gopt Opt_SuppressTypeSignatures dflags -> 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 + = ptext (sLit "@") <+> pprTvBndr 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 + = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressIdInfo dflags + then empty + else megaSeqIdInfo 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 (isNoOcc occ_info) + has_dmd = not $ isTopDmd dmd_info + has_lbv = not (hasNoOneShotInfo lbv_info) + + doc = showAttributes + [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info) + , (has_occ, ptext (sLit "Occ=") <> ppr occ_info) + , (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info) + , (has_lbv , ptext (sLit "OS=") <> ppr lbv_info) + ] + +{- +----------------------------------------------------- +-- IdDetails and IdInfo +----------------------------------------------------- +-} + +ppIdInfo :: Id -> IdInfo -> SDoc +ppIdInfo id info + = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressIdInfo dflags + then empty + else + showAttributes + [ (True, pp_scope <> ppr (idDetails id)) + , (has_arity, ptext (sLit "Arity=") <> int arity) + , (has_called_arity, ptext (sLit "CallArity=") <> int called_arity) + , (has_caf_info, ptext (sLit "Caf=") <> ppr caf_info) + , (True, ptext (sLit "Str=") <> pprStrictness str_info) + , (has_unf, ptext (sLit "Unf=") <> ppr unf_info) + , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules)) + ] -- Inline pragma, occ, demand, one-shot info + -- printed out with all binders (when debug is on); + -- see PprCore.pprIdBndr + where + pp_scope | isGlobalId id = ptext (sLit "GblId") + | isExportedId id = ptext (sLit "LclIdX") + | otherwise = ptext (sLit "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 + + unf_info = unfoldingInfo info + has_unf = hasSomeUnfolding unf_info + + rules = specInfoRules (specInfo 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 = ptext (sLit "NEVER") + ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }) + = ptext (sLit "ALWAYS_IF") <> + parens (ptext (sLit "arity=") <> int arity <> comma <> + ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <> + ptext (sLit "boring_ok=") <> ppr boring_ok) + ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) + = hsep [ ptext (sLit "IF_ARGS"), + brackets (hsep (map int cs)), + int size, + int discount ] + +instance Outputable UnfoldingSource where + ppr InlineCompulsory = ptext (sLit "Compulsory") + ppr InlineStable = ptext (sLit "InlineStable") + ppr InlineRhs = ptext (sLit "") + +instance Outputable Unfolding where + ppr NoUnfolding = ptext (sLit "No unfolding") + ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs + ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = hang (ptext (sLit "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 }) + = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs) + where + pp_info = fsep $ punctuate comma + [ ptext (sLit "Src=") <> ppr src + , ptext (sLit "TopLvl=") <> ppr top + , ptext (sLit "Value=") <> ppr hnf + , ptext (sLit "ConLike=") <> ppr conlike + , ptext (sLit "WorkFree=") <> ppr wf + , ptext (sLit "Expandable=") <> ppr exp + , ptext (sLit "Guidance=") <> ppr g ] + pp_tmpl = ptext (sLit "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}) + = ptext (sLit "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 [ptext (sLit "forall") <+> + sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, + nest 2 (ppr fn <+> sep (map pprArg tpl_args)), + nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) + ]) + +{- +----------------------------------------------------- +-- Tickish +----------------------------------------------------- +-} + +instance Outputable id => Outputable (Tickish id) where + ppr (HpcTick modl ix) = + hcat [ptext (sLit "tick<"), + ppr modl, comma, + ppr ix, + ptext (sLit ">")] + ppr (Breakpoint ix vars) = + hcat [ptext (sLit "break<"), + ppr ix, + ptext (sLit ">"), + parens (hcat (punctuate comma (map ppr vars)))] + ppr (ProfNote { profNoteCC = cc, + profNoteCount = tick, + profNoteScope = scope }) = + case (tick,scope) of + (True,True) -> hcat [ptext (sLit "scctick<"), ppr cc, char '>'] + (True,False) -> hcat [ptext (sLit "tick<"), ppr cc, char '>'] + _ -> hcat [ptext (sLit "scc<"), ppr cc, char '>'] + +{- +----------------------------------------------------- +-- Vectorisation declarations +----------------------------------------------------- +-} + +instance Outputable CoreVect where + ppr (Vect var e) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=') + 4 (pprCoreExpr e) + ppr (NoVect var) = ptext (sLit "NOVECTORISE") <+> ppr var + ppr (VectType False var Nothing) = ptext (sLit "VECTORISE type") <+> ppr var + ppr (VectType True var Nothing) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var + ppr (VectType False var (Just tc)) = ptext (sLit "VECTORISE type") <+> ppr var <+> char '=' <+> + ppr tc + ppr (VectType True var (Just tc)) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+> + char '=' <+> ppr tc + ppr (VectClass tc) = ptext (sLit "VECTORISE class") <+> ppr tc + ppr (VectInst var) = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs deleted file mode 100644 index 593c670cae..0000000000 --- a/compiler/coreSyn/PprCore.lhs +++ /dev/null @@ -1,536 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1996-1998 -% - -Printing of Core syntax - -\begin{code} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module PprCore ( - pprCoreExpr, pprParendExpr, - pprCoreBinding, pprCoreBindings, pprCoreAlt, - pprRules - ) where - -import CoreSyn -import Literal( pprLiteral ) -import Name( pprInfixName, pprPrefixName ) -import Var -import Id -import IdInfo -import Demand -import DataCon -import TyCon -import Type -import Coercion -import DynFlags -import BasicTypes -import Util -import Outputable -import FastString -\end{code} - -%************************************************************************ -%* * -\subsection{Public interfaces for Core printing (excluding instances)} -%* * -%************************************************************************ - -@pprParendCoreExpr@ puts parens around non-atomic Core expressions. - -\begin{code} -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 -pprCoreBinding = pprTopBind - -instance OutputableBndr b => Outputable (Bind b) where - ppr bind = ppr_bind bind - -instance OutputableBndr b => Outputable (Expr b) where - ppr expr = pprCoreExpr expr -\end{code} - - -%************************************************************************ -%* * -\subsection{The guts} -%* * -%************************************************************************ - -\begin{code} -pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc -pprTopBinds binds = vcat (map pprTopBind binds) - -pprTopBind :: OutputableBndr a => Bind a -> SDoc -pprTopBind (NonRec binder expr) - = ppr_binding (binder,expr) $$ blankLine - -pprTopBind (Rec []) - = ptext (sLit "Rec { }") -pprTopBind (Rec (b:bs)) - = vcat [ptext (sLit "Rec {"), - ppr_binding b, - vcat [blankLine $$ ppr_binding b | b <- bs], - ptext (sLit "end Rec }"), - blankLine] -\end{code} - -\begin{code} -ppr_bind :: OutputableBndr b => Bind b -> SDoc - -ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr) -ppr_bind (Rec binds) = vcat (map pp binds) - where - pp bind = ppr_binding bind <> semi - -ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc -ppr_binding (val_bdr, expr) - = pprBndr LetBind val_bdr $$ - hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr) -\end{code} - -\begin{code} -pprParendExpr expr = ppr_expr parens expr -pprCoreExpr expr = ppr_expr noParens expr - -noParens :: SDoc -> SDoc -noParens pp = pp -\end{code} - -\begin{code} -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 _ (Var name) = ppr name -ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Weird -ppr_expr add_par (Coercion co) = add_par (ptext (sLit "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, - ptext (sLit "`cast`") <+> pprCo co] - where - pprCo co = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressCoercions dflags - then ptext (sLit "...") - else parens $ - sep [ppr co, dcolon <+> ppr (coercionType co)] - - -ppr_expr add_par expr@(Lam _ _) - = let - (bndrs, body) = collectBinders expr - in - add_par $ - hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) - 2 (pprCoreExpr body) - -ppr_expr add_par expr@(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 = sep (punctuate comma (map pprCoreExpr val_args)) - 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 && isTupleTyCon tc - -> tupleParens (tupleTyConSort tc) pp_tup_args - where - tc = dataConTyCon dc - saturated = val_args `lengthIs` idArity f - - _ -> add_par (hang (ppr f) 2 pp_args) - - _ -> add_par (hang (pprParendExpr fun) 2 pp_args) - } - -ppr_expr add_par (Case expr var ty [(con,args,rhs)]) - = sdocWithDynFlags $ \dflags -> - if gopt Opt_PprCaseAsLet dflags - then add_par $ -- See Note [Print case as let] - sep [ sep [ ptext (sLit "let! {") - <+> ppr_case_pat con args - <+> ptext (sLit "~") - <+> ppr_bndr var - , ptext (sLit "<-") <+> ppr_expr id expr - <+> ptext (sLit "} in") ] - , pprCoreExpr rhs - ] - else add_par $ - sep [sep [ptext (sLit "case") <+> pprCoreExpr expr, - ifPprDebug (braces (ppr ty)), - sep [ptext (sLit "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 [ptext (sLit "case") - <+> pprCoreExpr expr - <+> ifPprDebug (braces (ppr ty)), - ptext (sLit "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 [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], - nest 2 (pprCoreExpr rhs), - ptext (sLit "} in"), - pprCoreExpr body ] - -ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) - = add_par - (hang (ptext (sLit "let {")) - 2 (hsep [ppr_binding (val_bdr,rhs), - ptext (sLit "} in")]) - $$ - pprCoreExpr expr) --} - --- General case (recursive case, too) -ppr_expr add_par (Let bind expr) - = add_par $ - sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")), - pprCoreExpr expr] - where - keyword = case bind of - Rec _ -> (sLit "letrec {") - NonRec _ _ -> (sLit "let {") - -ppr_expr add_par (Tick tickish expr) - = 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 - | isTupleTyCon tc - = tupleParens (tupleTyConSort tc) (hsep (punctuate comma (map ppr_bndr args))) - where - ppr_bndr = pprBndr CaseBind - tc = dataConTyCon dc - -ppr_case_pat con args - = ppr con <+> (fsep (map ppr_bndr args)) - where - ppr_bndr = pprBndr CaseBind - - --- | Pretty print the argument in a function application. -pprArg :: OutputableBndr a => Expr a -> SDoc -pprArg (Type ty) - = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressTypeApplications dflags - then empty - else ptext (sLit "@") <+> pprParendType ty -pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co -pprArg expr = pprParendExpr expr -\end{code} - -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. - -\begin{code} -instance OutputableBndr Var where - pprBndr = pprCoreBinder - pprInfixOcc = pprInfixName . varName - pprPrefixOcc = pprPrefixName . varName - -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 = ptext (sLit "@") <+> 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 - = sdocWithDynFlags $ \dflags -> - case () of - _ - | 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 - - | suppress_sigs dflags -> pprUntypedBinder var - - | isTyVar var -> parens (pprKindedTyVarBndr var) - - | otherwise -> parens (hang (pprIdBndr var) - 2 (vcat [ dcolon <+> pprType (idType var) - , pp_unf])) - where - suppress_sigs = gopt Opt_SuppressTypeSignatures - - unf_info = unfoldingInfo (idInfo var) - pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info - | otherwise = empty - -pprTypedLetBinder :: Var -> SDoc --- Print binder with a type or kind signature (not paren'd) -pprTypedLetBinder binder - = sdocWithDynFlags $ \dflags -> - case () of - _ - | isTyVar binder -> pprKindedTyVarBndr binder - | gopt Opt_SuppressTypeSignatures dflags -> 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 - = ptext (sLit "@") <+> pprTvBndr 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 - = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressIdInfo dflags - then empty - else megaSeqIdInfo 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 (isNoOcc occ_info) - has_dmd = not $ isTopDmd dmd_info - has_lbv = not (hasNoOneShotInfo lbv_info) - - doc = showAttributes - [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info) - , (has_occ, ptext (sLit "Occ=") <> ppr occ_info) - , (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info) - , (has_lbv , ptext (sLit "OS=") <> ppr lbv_info) - ] -\end{code} - - ------------------------------------------------------ --- IdDetails and IdInfo ------------------------------------------------------ - -\begin{code} -ppIdInfo :: Id -> IdInfo -> SDoc -ppIdInfo id info - = sdocWithDynFlags $ \dflags -> - if gopt Opt_SuppressIdInfo dflags - then empty - else - showAttributes - [ (True, pp_scope <> ppr (idDetails id)) - , (has_arity, ptext (sLit "Arity=") <> int arity) - , (has_called_arity, ptext (sLit "CallArity=") <> int called_arity) - , (has_caf_info, ptext (sLit "Caf=") <> ppr caf_info) - , (True, ptext (sLit "Str=") <> pprStrictness str_info) - , (has_unf, ptext (sLit "Unf=") <> ppr unf_info) - , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules)) - ] -- Inline pragma, occ, demand, one-shot info - -- printed out with all binders (when debug is on); - -- see PprCore.pprIdBndr - where - pp_scope | isGlobalId id = ptext (sLit "GblId") - | isExportedId id = ptext (sLit "LclIdX") - | otherwise = ptext (sLit "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 - - unf_info = unfoldingInfo info - has_unf = hasSomeUnfolding unf_info - - rules = specInfoRules (specInfo info) - -showAttributes :: [(Bool,SDoc)] -> SDoc -showAttributes stuff - | null docs = empty - | otherwise = brackets (sep (punctuate comma docs)) - where - docs = [d | (True,d) <- stuff] -\end{code} - ------------------------------------------------------ --- Unfolding and UnfoldingGuidance ------------------------------------------------------ - -\begin{code} -instance Outputable UnfoldingGuidance where - ppr UnfNever = ptext (sLit "NEVER") - ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }) - = ptext (sLit "ALWAYS_IF") <> - parens (ptext (sLit "arity=") <> int arity <> comma <> - ptext (sLit "unsat_ok=") <> ppr unsat_ok <> comma <> - ptext (sLit "boring_ok=") <> ppr boring_ok) - ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) - = hsep [ ptext (sLit "IF_ARGS"), - brackets (hsep (map int cs)), - int size, - int discount ] - -instance Outputable UnfoldingSource where - ppr InlineCompulsory = ptext (sLit "Compulsory") - ppr InlineStable = ptext (sLit "InlineStable") - ppr InlineRhs = ptext (sLit "") - -instance Outputable Unfolding where - ppr NoUnfolding = ptext (sLit "No unfolding") - ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs - ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) - = hang (ptext (sLit "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 }) - = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs) - where - pp_info = fsep $ punctuate comma - [ ptext (sLit "Src=") <> ppr src - , ptext (sLit "TopLvl=") <> ppr top - , ptext (sLit "Value=") <> ppr hnf - , ptext (sLit "ConLike=") <> ppr conlike - , ptext (sLit "WorkFree=") <> ppr wf - , ptext (sLit "Expandable=") <> ppr exp - , ptext (sLit "Guidance=") <> ppr g ] - pp_tmpl = ptext (sLit "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! -\end{code} - ------------------------------------------------------ --- Rules ------------------------------------------------------ - -\begin{code} -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}) - = ptext (sLit "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 [ptext (sLit "forall") <+> - sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, - nest 2 (ppr fn <+> sep (map pprArg tpl_args)), - nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) - ]) -\end{code} - ------------------------------------------------------ --- Tickish ------------------------------------------------------ - -\begin{code} -instance Outputable id => Outputable (Tickish id) where - ppr (HpcTick modl ix) = - hcat [ptext (sLit "tick<"), - ppr modl, comma, - ppr ix, - ptext (sLit ">")] - ppr (Breakpoint ix vars) = - hcat [ptext (sLit "break<"), - ppr ix, - ptext (sLit ">"), - parens (hcat (punctuate comma (map ppr vars)))] - ppr (ProfNote { profNoteCC = cc, - profNoteCount = tick, - profNoteScope = scope }) = - case (tick,scope) of - (True,True) -> hcat [ptext (sLit "scctick<"), ppr cc, char '>'] - (True,False) -> hcat [ptext (sLit "tick<"), ppr cc, char '>'] - _ -> hcat [ptext (sLit "scc<"), ppr cc, char '>'] -\end{code} - ------------------------------------------------------ --- Vectorisation declarations ------------------------------------------------------ - -\begin{code} -instance Outputable CoreVect where - ppr (Vect var e) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=') - 4 (pprCoreExpr e) - ppr (NoVect var) = ptext (sLit "NOVECTORISE") <+> ppr var - ppr (VectType False var Nothing) = ptext (sLit "VECTORISE type") <+> ppr var - ppr (VectType True var Nothing) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var - ppr (VectType False var (Just tc)) = ptext (sLit "VECTORISE type") <+> ppr var <+> char '=' <+> - ppr tc - ppr (VectType True var (Just tc)) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+> - char '=' <+> ppr tc - ppr (VectClass tc) = ptext (sLit "VECTORISE class") <+> ppr tc - ppr (VectInst var) = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var -\end{code} diff --git a/compiler/coreSyn/TrieMap.hs b/compiler/coreSyn/TrieMap.hs new file mode 100644 index 0000000000..57f360e181 --- /dev/null +++ b/compiler/coreSyn/TrieMap.hs @@ -0,0 +1,829 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE RankNTypes, TypeFamilies #-} +module TrieMap( + CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, + TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, + CoercionMap, + MaybeMap, + ListMap, + TrieMap(..), insertTM, deleteTM, + lookupTypeMapTyCon + ) where + +import CoreSyn +import Coercion +import Literal +import Name +import Type +import TypeRep +import TyCon(TyCon) +import Var +import UniqFM +import Unique( Unique ) +import FastString(FastString) +import CoAxiom(CoAxiomRule(coaxrName)) + +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, which are finite mappings +whose key is a structured value like a CoreExpr or Type. + +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. + +************************************************************************ +* * + The TrieMap class +* * +************************************************************************ +-} + +type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) + -- or an existing elt (Just) + +class TrieMap m where + type Key m :: * + emptyTM :: m a + lookupTM :: forall b. Key m -> m b -> Maybe b + alterTM :: forall b. Key m -> XT b -> m b -> m b + mapTM :: (a->b) -> m a -> m b + + foldTM :: (a -> b -> b) -> m a -> b -> b + -- The unusual argument order here makes + -- it easy to compose calls to foldTM; + -- see for example fdE below + +insertTM :: TrieMap m => Key m -> a -> m a -> m a +insertTM k v m = alterTM k (\_ -> Just v) m + +deleteTM :: TrieMap m => Key m -> m a -> m a +deleteTM k m = alterTM k (\_ -> Nothing) m + +---------------------- +-- Recall that +-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c + +(>.>) :: (a -> b) -> (b -> c) -> a -> c +-- Reverse function composition (do f first, then g) +infixr 1 >.> +(f >.> g) x = g (f x) +infixr 1 |>, |>> + +(|>) :: a -> (a->b) -> b -- Reverse application +x |> f = f x + +---------------------- +(|>>) :: TrieMap m2 + => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) + -> (m2 a -> m2 a) + -> m1 (m2 a) -> m1 (m2 a) +(|>>) f g = f (Just . g . deMaybe) + +deMaybe :: TrieMap m => Maybe (m a) -> m a +deMaybe Nothing = emptyTM +deMaybe (Just m) = m + +{- +************************************************************************ +* * + IntMaps +* * +************************************************************************ +-} + +instance TrieMap IntMap.IntMap where + type Key IntMap.IntMap = Int + emptyTM = IntMap.empty + lookupTM k m = IntMap.lookup k m + alterTM = xtInt + foldTM k m z = IntMap.fold k z m + mapTM f m = IntMap.map f m + +xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a +xtInt k f m = IntMap.alter f k m + +instance Ord k => TrieMap (Map.Map k) where + type Key (Map.Map k) = k + emptyTM = Map.empty + lookupTM = Map.lookup + alterTM k f m = Map.alter f k m + foldTM k m z = Map.fold k z m + mapTM f m = Map.map f m + +instance TrieMap UniqFM where + type Key UniqFM = Unique + emptyTM = emptyUFM + lookupTM k m = lookupUFM m k + alterTM k f m = alterUFM f m k + foldTM k m z = foldUFM k z m + mapTM f m = mapUFM f m + +{- +************************************************************************ +* * + Lists +* * +************************************************************************ + +If m is a map from k -> val +then (MaybeMap m) is a map from (Maybe k) -> val +-} + +data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } + +instance TrieMap m => TrieMap (MaybeMap m) where + type Key (MaybeMap m) = Maybe (Key m) + emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } + lookupTM = lkMaybe lookupTM + alterTM = xtMaybe alterTM + foldTM = fdMaybe + mapTM = mapMb + +mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b +mapMb f (MM { mm_nothing = mn, mm_just = mj }) + = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj } + +lkMaybe :: TrieMap m => (forall b. k -> m b -> Maybe b) + -> Maybe k -> MaybeMap m a -> Maybe a +lkMaybe _ Nothing = mm_nothing +lkMaybe lk (Just x) = mm_just >.> lk x + +xtMaybe :: TrieMap m => (forall b. k -> XT b -> m b -> m b) + -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a +xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) } +xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f } + +fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b +fdMaybe k m = foldMaybe k (mm_nothing m) + . foldTM k (mm_just m) + +-------------------- +data ListMap m a + = LM { lm_nil :: Maybe a + , lm_cons :: m (ListMap m a) } + +instance TrieMap m => TrieMap (ListMap m) where + type Key (ListMap m) = [Key m] + emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } + lookupTM = lkList lookupTM + alterTM = xtList alterTM + foldTM = fdList + mapTM = mapList + +mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b +mapList f (LM { lm_nil = mnil, lm_cons = mcons }) + = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons } + +lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) + -> [k] -> ListMap m a -> Maybe a +lkList _ [] = lm_nil +lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs + +xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b) + -> [k] -> XT a -> ListMap m a -> ListMap m a +xtList _ [] f m = m { lm_nil = f (lm_nil m) } +xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f } + +fdList :: forall m a b. TrieMap m + => (a -> b -> b) -> ListMap m a -> b -> b +fdList k m = foldMaybe k (lm_nil m) + . foldTM (fdList k) (lm_cons m) + +foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b +foldMaybe _ Nothing b = b +foldMaybe k (Just a) b = k a b + +{- +************************************************************************ +* * + Basic maps +* * +************************************************************************ +-} + +lkNamed :: NamedThing n => n -> NameEnv a -> Maybe a +lkNamed n env = lookupNameEnv env (getName n) + +xtNamed :: NamedThing n => n -> XT a -> NameEnv a -> NameEnv a +xtNamed tc f m = alterNameEnv f m (getName tc) + +------------------------ +type LiteralMap a = Map.Map Literal a + +emptyLiteralMap :: LiteralMap a +emptyLiteralMap = emptyTM + +lkLit :: Literal -> LiteralMap a -> Maybe a +lkLit = lookupTM + +xtLit :: Literal -> XT a -> LiteralMap a -> LiteralMap a +xtLit = alterTM + +{- +************************************************************************ +* * + CoreMap +* * +************************************************************************ + +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 :: CoreMap (TypeMap a) + rather than + cm_lam :: TypeMap (CoreMap a) + + * We don't need to look at the type of some binders, notalby + - 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 (Trac #6097) + +We could compare the return type regardless, but the wildly common case +is that it's unnecesary, 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 CoreSyn. +-} + +data CoreMap a + = EmptyCM + | CM { cm_var :: VarMap a + , cm_lit :: LiteralMap a + , cm_co :: CoercionMap a + , cm_type :: TypeMap a + , cm_cast :: CoreMap (CoercionMap a) + , cm_tick :: CoreMap (TickishMap a) + , cm_app :: CoreMap (CoreMap a) + , cm_lam :: CoreMap (TypeMap a) -- Note [Binders] + , cm_letn :: CoreMap (CoreMap (BndrMap a)) + , cm_letr :: ListMap CoreMap (CoreMap (ListMap BndrMap a)) + , cm_case :: CoreMap (ListMap AltMap a) + , cm_ecase :: CoreMap (TypeMap a) -- Note [Empty case alternatives] + } + + +wrapEmptyCM :: CoreMap a +wrapEmptyCM = CM { cm_var = emptyTM, cm_lit = emptyLiteralMap + , 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 CoreMap where + type Key CoreMap = CoreExpr + emptyTM = EmptyCM + lookupTM = lkE emptyCME + alterTM = xtE emptyCME + foldTM = fdE + mapTM = mapE + +-------------------------- +mapE :: (a->b) -> CoreMap a -> CoreMap b +mapE _ EmptyCM = EmptyCM +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 = lkE emptyCME e cm + +extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a +extendCoreMap m e v = xtE emptyCME e (\_ -> Just v) m + +foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b +foldCoreMap k z m = fdE k m z + +emptyCoreMap :: CoreMap a +emptyCoreMap = EmptyCM + +instance Outputable a => Outputable (CoreMap a) where + ppr m = text "CoreMap elts" <+> ppr (foldCoreMap (:) [] m) + +------------------------- +fdE :: (a -> b -> b) -> CoreMap a -> b -> b +fdE _ EmptyCM = \z -> z +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 :: CmEnv -> CoreExpr -> CoreMap a -> Maybe a +-- lkE: lookup in trie for expressions +lkE env expr cm + | EmptyCM <- cm = Nothing + | otherwise = go expr cm + where + go (Var v) = cm_var >.> lkVar env v + go (Lit l) = cm_lit >.> lkLit l + go (Type t) = cm_type >.> lkT env t + go (Coercion c) = cm_co >.> lkC env c + go (Cast e c) = cm_cast >.> lkE env e >=> lkC env c + go (Tick tickish e) = cm_tick >.> lkE env e >=> lkTickish tickish + go (App e1 e2) = cm_app >.> lkE env e2 >=> lkE env e1 + go (Lam v e) = cm_lam >.> lkE (extendCME env v) e >=> lkBndr env v + go (Let (NonRec b r) e) = cm_letn >.> lkE env r + >=> lkE (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 (lkE env1) rhss >=> lkE env1 e + >=> lkList (lkBndr env1) bndrs + go (Case e b ty as) -- See Note [Empty case alternatives] + | null as = cm_ecase >.> lkE env e >=> lkT env ty + | otherwise = cm_case >.> lkE env e + >=> lkList (lkA (extendCME env b)) as + +xtE :: CmEnv -> CoreExpr -> XT a -> CoreMap a -> CoreMap a +xtE env e f EmptyCM = xtE env e f wrapEmptyCM +xtE env (Var v) f m = m { cm_var = cm_var m |> xtVar env v f } +xtE env (Type t) f m = m { cm_type = cm_type m |> xtT env t f } +xtE env (Coercion c) f m = m { cm_co = cm_co m |> xtC env c f } +xtE _ (Lit l) f m = m { cm_lit = cm_lit m |> xtLit l f } +xtE env (Cast e c) f m = m { cm_cast = cm_cast m |> xtE env e |>> + xtC env c f } +xtE env (Tick t e) f m = m { cm_tick = cm_tick m |> xtE env e |>> xtTickish t f } +xtE env (App e1 e2) f m = m { cm_app = cm_app m |> xtE env e2 |>> xtE env e1 f } +xtE env (Lam v e) f m = m { cm_lam = cm_lam m |> xtE (extendCME env v) e + |>> xtBndr env v f } +xtE env (Let (NonRec b r) e) f m = m { cm_letn = cm_letn m + |> xtE (extendCME env b) e + |>> xtE env r |>> xtBndr env b f } +xtE env (Let (Rec prs) e) f m = m { cm_letr = let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr m + |> xtList (xtE env1) rhss + |>> xtE env1 e + |>> xtList (xtBndr env1) bndrs f } +xtE env (Case e b ty as) f m + | null as = m { cm_ecase = cm_ecase m |> xtE env e |>> xtT env ty f } + | otherwise = m { cm_case = cm_case m |> xtE env e + |>> let env1 = extendCME env b + in xtList (xtA env1) as f } + +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 :: CoreMap a + , am_data :: NameEnv (CoreMap a) + , am_lit :: LiteralMap (CoreMap a) } + +instance TrieMap AltMap where + type Key AltMap = CoreAlt + emptyTM = AM { am_deflt = emptyTM + , am_data = emptyNameEnv + , am_lit = emptyLiteralMap } + lookupTM = lkA emptyCME + alterTM = xtA emptyCME + foldTM = fdA + mapTM = mapA + +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 = mapNameEnv (mapTM f) adata + , am_lit = mapTM (mapTM f) alit } + +lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a +lkA env (DEFAULT, _, rhs) = am_deflt >.> lkE env rhs +lkA env (LitAlt lit, _, rhs) = am_lit >.> lkLit lit >=> lkE env rhs +lkA env (DataAlt dc, bs, rhs) = am_data >.> lkNamed dc >=> lkE (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 |> xtE env rhs f } +xtA env (LitAlt l, _, rhs) f m = m { am_lit = am_lit m |> xtLit l |>> xtE env rhs f } +xtA env (DataAlt d, bs, rhs) f m = m { am_data = am_data m |> xtNamed d + |>> xtE (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 +* * +************************************************************************ +-} + +data CoercionMap a + = EmptyKM + | KM { km_refl :: RoleMap (TypeMap a) + , km_tc_app :: RoleMap (NameEnv (ListMap CoercionMap a)) + , km_app :: CoercionMap (CoercionMap a) + , km_forall :: CoercionMap (TypeMap a) + , km_var :: VarMap a + , km_axiom :: NameEnv (IntMap.IntMap (ListMap CoercionMap a)) + , km_univ :: RoleMap (TypeMap (TypeMap a)) + , km_sym :: CoercionMap a + , km_trans :: CoercionMap (CoercionMap a) + , km_nth :: IntMap.IntMap (CoercionMap a) + , km_left :: CoercionMap a + , km_right :: CoercionMap a + , km_inst :: CoercionMap (TypeMap a) + , km_sub :: CoercionMap a + , km_axiom_rule :: Map.Map FastString + (ListMap TypeMap (ListMap CoercionMap a)) + } + +wrapEmptyKM :: CoercionMap a +wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyTM + , km_app = emptyTM, km_forall = emptyTM + , km_var = emptyTM, km_axiom = emptyNameEnv + , km_univ = emptyTM, km_sym = emptyTM, km_trans = emptyTM + , km_nth = emptyTM, km_left = emptyTM, km_right = emptyTM + , km_inst = emptyTM, km_sub = emptyTM + , km_axiom_rule = emptyTM } + +instance TrieMap CoercionMap where + type Key CoercionMap = Coercion + emptyTM = EmptyKM + lookupTM = lkC emptyCME + alterTM = xtC emptyCME + foldTM = fdC + mapTM = mapC + +mapC :: (a->b) -> CoercionMap a -> CoercionMap b +mapC _ EmptyKM = EmptyKM +mapC f (KM { km_refl = krefl, km_tc_app = ktc + , km_app = kapp, km_forall = kforall + , km_var = kvar, km_axiom = kax + , km_univ = kuniv , km_sym = ksym, km_trans = ktrans + , km_nth = knth, km_left = kml, km_right = kmr + , km_inst = kinst, km_sub = ksub + , km_axiom_rule = kaxr }) + = KM { km_refl = mapTM (mapTM f) krefl + , km_tc_app = mapTM (mapNameEnv (mapTM f)) ktc + , km_app = mapTM (mapTM f) kapp + , km_forall = mapTM (mapTM f) kforall + , km_var = mapTM f kvar + , km_axiom = mapNameEnv (IntMap.map (mapTM f)) kax + , km_univ = mapTM (mapTM (mapTM f)) kuniv + , km_sym = mapTM f ksym + , km_trans = mapTM (mapTM f) ktrans + , km_nth = IntMap.map (mapTM f) knth + , km_left = mapTM f kml + , km_right = mapTM f kmr + , km_inst = mapTM (mapTM f) kinst + , km_sub = mapTM f ksub + , km_axiom_rule = mapTM (mapTM (mapTM f)) kaxr + } + +lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a +lkC env co m + | EmptyKM <- m = Nothing + | otherwise = go co m + where + go (Refl r ty) = km_refl >.> lookupTM r >=> lkT env ty + go (TyConAppCo r tc cs) = km_tc_app >.> lookupTM r >=> lkNamed tc >=> lkList (lkC env) cs + go (AxiomInstCo ax ind cs) = km_axiom >.> lkNamed ax >=> lookupTM ind >=> lkList (lkC env) cs + go (AppCo c1 c2) = km_app >.> lkC env c1 >=> lkC env c2 + go (TransCo c1 c2) = km_trans >.> lkC env c1 >=> lkC env c2 + go (UnivCo r t1 t2) = km_univ >.> lookupTM r >=> lkT env t1 >=> lkT env t2 + go (InstCo c t) = km_inst >.> lkC env c >=> lkT env t + go (ForAllCo v c) = km_forall >.> lkC (extendCME env v) c >=> lkBndr env v + go (CoVarCo v) = km_var >.> lkVar env v + go (SymCo c) = km_sym >.> lkC env c + go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c + go (LRCo CLeft c) = km_left >.> lkC env c + go (LRCo CRight c) = km_right >.> lkC env c + go (SubCo c) = km_sub >.> lkC env c + go (AxiomRuleCo co ts cs) = km_axiom_rule >.> + lookupTM (coaxrName co) >=> + lkList (lkT env) ts >=> + lkList (lkC env) cs + + +xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a +xtC env co f EmptyKM = xtC env co f wrapEmptyKM +xtC env (Refl r ty) f m = m { km_refl = km_refl m |> xtR r |>> xtT env ty f } +xtC env (TyConAppCo r tc cs) f m = m { km_tc_app = km_tc_app m |> xtR r |>> xtNamed tc |>> xtList (xtC env) cs f } +xtC env (AxiomInstCo ax ind cs) f m = m { km_axiom = km_axiom m |> xtNamed ax |>> xtInt ind |>> xtList (xtC env) cs f } +xtC env (AppCo c1 c2) f m = m { km_app = km_app m |> xtC env c1 |>> xtC env c2 f } +xtC env (TransCo c1 c2) f m = m { km_trans = km_trans m |> xtC env c1 |>> xtC env c2 f } +xtC env (UnivCo r t1 t2) f m = m { km_univ = km_univ m |> xtR r |>> xtT env t1 |>> xtT env t2 f } +xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f } +xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c + |>> xtBndr env v f } +xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f } +xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f } +xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f } +xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f } +xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f } +xtC env (SubCo c) f m = m { km_sub = km_sub m |> xtC env c f } +xtC env (AxiomRuleCo co ts cs) f m = m { km_axiom_rule = km_axiom_rule m + |> alterTM (coaxrName co) + |>> xtList (xtT env) ts + |>> xtList (xtC env) cs f} + +fdC :: (a -> b -> b) -> CoercionMap a -> b -> b +fdC _ EmptyKM = \z -> z +fdC k m = foldTM (foldTM k) (km_refl m) + . foldTM (foldTM (foldTM k)) (km_tc_app m) + . foldTM (foldTM k) (km_app m) + . foldTM (foldTM k) (km_forall m) + . foldTM k (km_var m) + . foldTM (foldTM (foldTM k)) (km_axiom m) + . foldTM (foldTM (foldTM k)) (km_univ m) + . foldTM k (km_sym m) + . foldTM (foldTM k) (km_trans m) + . foldTM (foldTM k) (km_nth m) + . foldTM k (km_left m) + . foldTM k (km_right m) + . foldTM (foldTM k) (km_inst m) + . foldTM k (km_sub m) + . foldTM (foldTM (foldTM k)) (km_axiom_rule m) + +newtype RoleMap a = RM { unRM :: (IntMap.IntMap a) } + +instance TrieMap RoleMap where + type Key RoleMap = Role + emptyTM = RM emptyTM + lookupTM = lkR + alterTM = xtR + foldTM = fdR + mapTM = mapR + +lkR :: Role -> RoleMap a -> Maybe a +lkR Nominal = lookupTM 1 . unRM +lkR Representational = lookupTM 2 . unRM +lkR Phantom = lookupTM 3 . unRM + +xtR :: Role -> XT a -> RoleMap a -> RoleMap a +xtR Nominal f = RM . alterTM 1 f . unRM +xtR Representational f = RM . alterTM 2 f . unRM +xtR Phantom f = RM . alterTM 3 f . unRM + +fdR :: (a -> b -> b) -> RoleMap a -> b -> b +fdR f (RM m) = foldTM f m + +mapR :: (a -> b) -> RoleMap a -> RoleMap b +mapR f = RM . mapTM f . unRM + +{- +************************************************************************ +* * + Types +* * +************************************************************************ +-} + +data TypeMap a + = EmptyTM + | TM { tm_var :: VarMap a + , tm_app :: TypeMap (TypeMap a) + , tm_fun :: TypeMap (TypeMap a) + , tm_tc_app :: NameEnv (ListMap TypeMap a) + , tm_forall :: TypeMap (BndrMap a) + , tm_tylit :: TyLitMap a + } + + +instance Outputable a => Outputable (TypeMap a) where + ppr m = text "TypeMap elts" <+> ppr (foldTypeMap (:) [] m) + +foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b +foldTypeMap k z m = fdT k m z + +emptyTypeMap :: TypeMap a +emptyTypeMap = EmptyTM + +lookupTypeMap :: TypeMap a -> Type -> Maybe a +lookupTypeMap cm t = lkT emptyCME t cm + +-- Returns the type map entries that have keys starting with the given tycon. +-- This only considers saturated applications (i.e. TyConApp ones). +lookupTypeMapTyCon :: TypeMap a -> TyCon -> [a] +lookupTypeMapTyCon EmptyTM _ = [] +lookupTypeMapTyCon TM { tm_tc_app = cs } tc = + case lookupUFM cs tc of + Nothing -> [] + Just xs -> foldTM (:) xs [] + +extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a +extendTypeMap m t v = xtT emptyCME t (\_ -> Just v) m + +wrapEmptyTypeMap :: TypeMap a +wrapEmptyTypeMap = TM { tm_var = emptyTM + , tm_app = EmptyTM + , tm_fun = EmptyTM + , tm_tc_app = emptyNameEnv + , tm_forall = EmptyTM + , tm_tylit = emptyTyLitMap } + +instance TrieMap TypeMap where + type Key TypeMap = Type + emptyTM = EmptyTM + lookupTM = lkT emptyCME + alterTM = xtT emptyCME + foldTM = fdT + mapTM = mapT + +mapT :: (a->b) -> TypeMap a -> TypeMap b +mapT _ EmptyTM = EmptyTM +mapT f (TM { tm_var = tvar, tm_app = tapp, tm_fun = tfun + , tm_tc_app = ttcapp, tm_forall = tforall, tm_tylit = tlit }) + = TM { tm_var = mapTM f tvar + , tm_app = mapTM (mapTM f) tapp + , tm_fun = mapTM (mapTM f) tfun + , tm_tc_app = mapNameEnv (mapTM f) ttcapp + , tm_forall = mapTM (mapTM f) tforall + , tm_tylit = mapTM f tlit } + +----------------- +lkT :: CmEnv -> Type -> TypeMap a -> Maybe a +lkT env ty m + | EmptyTM <- m = Nothing + | otherwise = go ty m + where + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy v) = tm_var >.> lkVar env v + go (AppTy t1 t2) = tm_app >.> lkT env t1 >=> lkT env t2 + go (FunTy t1 t2) = tm_fun >.> lkT env t1 >=> lkT env t2 + go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys + go (LitTy l) = tm_tylit >.> lkTyLit l + go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv + + +----------------- +xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a +xtT env ty f m + | EmptyTM <- m = xtT env ty f wrapEmptyTypeMap + | Just ty' <- coreView ty = xtT env ty' f m + +xtT env (TyVarTy v) f m = m { tm_var = tm_var m |> xtVar env v f } +xtT env (AppTy t1 t2) f m = m { tm_app = tm_app m |> xtT env t1 |>> xtT env t2 f } +xtT env (FunTy t1 t2) f m = m { tm_fun = tm_fun m |> xtT env t1 |>> xtT env t2 f } +xtT env (ForAllTy tv ty) f m = m { tm_forall = tm_forall m |> xtT (extendCME env tv) ty + |>> xtBndr env tv f } +xtT env (TyConApp tc tys) f m = m { tm_tc_app = tm_tc_app m |> xtNamed tc + |>> xtList (xtT env) tys f } +xtT _ (LitTy l) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } + +fdT :: (a -> b -> b) -> TypeMap a -> b -> b +fdT _ EmptyTM = \z -> z +fdT k m = foldTM k (tm_var m) + . foldTM (foldTM k) (tm_app m) + . foldTM (foldTM k) (tm_fun m) + . foldTM (foldTM k) (tm_tc_app m) + . foldTM (foldTM k) (tm_forall m) + . foldTyLit k (tm_tylit 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.fold l) (tlm_string m) + . flip (Map.fold l) (tlm_number 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 + +--------- Variable binders ------------- +type BndrMap = TypeMap + +lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a +lkBndr env v m = lkT env (varType v) m + +xtBndr :: CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a +xtBndr env v f = xtT env (varType v) f + +--------- Variable occurrence ------------- +data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable + , vm_fvar :: VarEnv a } -- Free variable + +instance TrieMap VarMap where + type Key VarMap = Var + emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyVarEnv } + 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 = mapVarEnv f fv } + +lkVar :: CmEnv -> Var -> VarMap a -> Maybe a +lkVar env v + | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv + | otherwise = vm_fvar >.> lkFreeVar 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 |> xtInt bv f } + | otherwise = m { vm_fvar = vm_fvar m |> xtFreeVar v f } + +fdVar :: (a -> b -> b) -> VarMap a -> b -> b +fdVar k m = foldTM k (vm_bvar m) + . foldTM k (vm_fvar m) + +lkFreeVar :: Var -> VarEnv a -> Maybe a +lkFreeVar var env = lookupVarEnv env var + +xtFreeVar :: Var -> XT a -> VarEnv a -> VarEnv a +xtFreeVar v f m = alterVarEnv f m v diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs deleted file mode 100644 index d552506b10..0000000000 --- a/compiler/coreSyn/TrieMap.lhs +++ /dev/null @@ -1,840 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -\begin{code} -{-# LANGUAGE RankNTypes, TypeFamilies #-} -module TrieMap( - CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, - TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, - CoercionMap, - MaybeMap, - ListMap, - TrieMap(..), insertTM, deleteTM, - lookupTypeMapTyCon - ) where - -import CoreSyn -import Coercion -import Literal -import Name -import Type -import TypeRep -import TyCon(TyCon) -import Var -import UniqFM -import Unique( Unique ) -import FastString(FastString) -import CoAxiom(CoAxiomRule(coaxrName)) - -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import VarEnv -import NameEnv -import Outputable -import Control.Monad( (>=>) ) -\end{code} - -This module implements TrieMaps, which are finite mappings -whose key is a structured value like a CoreExpr or Type. - -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. - -%************************************************************************ -%* * - The TrieMap class -%* * -%************************************************************************ - -\begin{code} -type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) - -- or an existing elt (Just) - -class TrieMap m where - type Key m :: * - emptyTM :: m a - lookupTM :: forall b. Key m -> m b -> Maybe b - alterTM :: forall b. Key m -> XT b -> m b -> m b - mapTM :: (a->b) -> m a -> m b - - foldTM :: (a -> b -> b) -> m a -> b -> b - -- The unusual argument order here makes - -- it easy to compose calls to foldTM; - -- see for example fdE below - -insertTM :: TrieMap m => Key m -> a -> m a -> m a -insertTM k v m = alterTM k (\_ -> Just v) m - -deleteTM :: TrieMap m => Key m -> m a -> m a -deleteTM k m = alterTM k (\_ -> Nothing) m - ----------------------- --- Recall that --- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c - -(>.>) :: (a -> b) -> (b -> c) -> a -> c --- Reverse function composition (do f first, then g) -infixr 1 >.> -(f >.> g) x = g (f x) -infixr 1 |>, |>> - -(|>) :: a -> (a->b) -> b -- Reverse application -x |> f = f x - ----------------------- -(|>>) :: TrieMap m2 - => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) - -> (m2 a -> m2 a) - -> m1 (m2 a) -> m1 (m2 a) -(|>>) f g = f (Just . g . deMaybe) - -deMaybe :: TrieMap m => Maybe (m a) -> m a -deMaybe Nothing = emptyTM -deMaybe (Just m) = m -\end{code} - -%************************************************************************ -%* * - IntMaps -%* * -%************************************************************************ - -\begin{code} -instance TrieMap IntMap.IntMap where - type Key IntMap.IntMap = Int - emptyTM = IntMap.empty - lookupTM k m = IntMap.lookup k m - alterTM = xtInt - foldTM k m z = IntMap.fold k z m - mapTM f m = IntMap.map f m - -xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a -xtInt k f m = IntMap.alter f k m - -instance Ord k => TrieMap (Map.Map k) where - type Key (Map.Map k) = k - emptyTM = Map.empty - lookupTM = Map.lookup - alterTM k f m = Map.alter f k m - foldTM k m z = Map.fold k z m - mapTM f m = Map.map f m - -instance TrieMap UniqFM where - type Key UniqFM = Unique - emptyTM = emptyUFM - lookupTM k m = lookupUFM m k - alterTM k f m = alterUFM f m k - foldTM k m z = foldUFM k z m - mapTM f m = mapUFM f m -\end{code} - - -%************************************************************************ -%* * - Lists -%* * -%************************************************************************ - -If m is a map from k -> val -then (MaybeMap m) is a map from (Maybe k) -> val - -\begin{code} -data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } - -instance TrieMap m => TrieMap (MaybeMap m) where - type Key (MaybeMap m) = Maybe (Key m) - emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } - lookupTM = lkMaybe lookupTM - alterTM = xtMaybe alterTM - foldTM = fdMaybe - mapTM = mapMb - -mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b -mapMb f (MM { mm_nothing = mn, mm_just = mj }) - = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj } - -lkMaybe :: TrieMap m => (forall b. k -> m b -> Maybe b) - -> Maybe k -> MaybeMap m a -> Maybe a -lkMaybe _ Nothing = mm_nothing -lkMaybe lk (Just x) = mm_just >.> lk x - -xtMaybe :: TrieMap m => (forall b. k -> XT b -> m b -> m b) - -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a -xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) } -xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f } - -fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b -fdMaybe k m = foldMaybe k (mm_nothing m) - . foldTM k (mm_just m) - --------------------- -data ListMap m a - = LM { lm_nil :: Maybe a - , lm_cons :: m (ListMap m a) } - -instance TrieMap m => TrieMap (ListMap m) where - type Key (ListMap m) = [Key m] - emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } - lookupTM = lkList lookupTM - alterTM = xtList alterTM - foldTM = fdList - mapTM = mapList - -mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b -mapList f (LM { lm_nil = mnil, lm_cons = mcons }) - = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons } - -lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) - -> [k] -> ListMap m a -> Maybe a -lkList _ [] = lm_nil -lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs - -xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b) - -> [k] -> XT a -> ListMap m a -> ListMap m a -xtList _ [] f m = m { lm_nil = f (lm_nil m) } -xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f } - -fdList :: forall m a b. TrieMap m - => (a -> b -> b) -> ListMap m a -> b -> b -fdList k m = foldMaybe k (lm_nil m) - . foldTM (fdList k) (lm_cons m) - -foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b -foldMaybe _ Nothing b = b -foldMaybe k (Just a) b = k a b -\end{code} - - -%************************************************************************ -%* * - Basic maps -%* * -%************************************************************************ - -\begin{code} -lkNamed :: NamedThing n => n -> NameEnv a -> Maybe a -lkNamed n env = lookupNameEnv env (getName n) - -xtNamed :: NamedThing n => n -> XT a -> NameEnv a -> NameEnv a -xtNamed tc f m = alterNameEnv f m (getName tc) - ------------------------- -type LiteralMap a = Map.Map Literal a - -emptyLiteralMap :: LiteralMap a -emptyLiteralMap = emptyTM - -lkLit :: Literal -> LiteralMap a -> Maybe a -lkLit = lookupTM - -xtLit :: Literal -> XT a -> LiteralMap a -> LiteralMap a -xtLit = alterTM -\end{code} - -%************************************************************************ -%* * - CoreMap -%* * -%************************************************************************ - -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 :: CoreMap (TypeMap a) - rather than - cm_lam :: TypeMap (CoreMap a) - - * We don't need to look at the type of some binders, notalby - - 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 (Trac #6097) - -We could compare the return type regardless, but the wildly common case -is that it's unnecesary, 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 CoreSyn. - -\begin{code} -data CoreMap a - = EmptyCM - | CM { cm_var :: VarMap a - , cm_lit :: LiteralMap a - , cm_co :: CoercionMap a - , cm_type :: TypeMap a - , cm_cast :: CoreMap (CoercionMap a) - , cm_tick :: CoreMap (TickishMap a) - , cm_app :: CoreMap (CoreMap a) - , cm_lam :: CoreMap (TypeMap a) -- Note [Binders] - , cm_letn :: CoreMap (CoreMap (BndrMap a)) - , cm_letr :: ListMap CoreMap (CoreMap (ListMap BndrMap a)) - , cm_case :: CoreMap (ListMap AltMap a) - , cm_ecase :: CoreMap (TypeMap a) -- Note [Empty case alternatives] - } - - -wrapEmptyCM :: CoreMap a -wrapEmptyCM = CM { cm_var = emptyTM, cm_lit = emptyLiteralMap - , 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 CoreMap where - type Key CoreMap = CoreExpr - emptyTM = EmptyCM - lookupTM = lkE emptyCME - alterTM = xtE emptyCME - foldTM = fdE - mapTM = mapE - --------------------------- -mapE :: (a->b) -> CoreMap a -> CoreMap b -mapE _ EmptyCM = EmptyCM -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 = lkE emptyCME e cm - -extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a -extendCoreMap m e v = xtE emptyCME e (\_ -> Just v) m - -foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b -foldCoreMap k z m = fdE k m z - -emptyCoreMap :: CoreMap a -emptyCoreMap = EmptyCM - -instance Outputable a => Outputable (CoreMap a) where - ppr m = text "CoreMap elts" <+> ppr (foldCoreMap (:) [] m) - -------------------------- -fdE :: (a -> b -> b) -> CoreMap a -> b -> b -fdE _ EmptyCM = \z -> z -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 :: CmEnv -> CoreExpr -> CoreMap a -> Maybe a --- lkE: lookup in trie for expressions -lkE env expr cm - | EmptyCM <- cm = Nothing - | otherwise = go expr cm - where - go (Var v) = cm_var >.> lkVar env v - go (Lit l) = cm_lit >.> lkLit l - go (Type t) = cm_type >.> lkT env t - go (Coercion c) = cm_co >.> lkC env c - go (Cast e c) = cm_cast >.> lkE env e >=> lkC env c - go (Tick tickish e) = cm_tick >.> lkE env e >=> lkTickish tickish - go (App e1 e2) = cm_app >.> lkE env e2 >=> lkE env e1 - go (Lam v e) = cm_lam >.> lkE (extendCME env v) e >=> lkBndr env v - go (Let (NonRec b r) e) = cm_letn >.> lkE env r - >=> lkE (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 (lkE env1) rhss >=> lkE env1 e - >=> lkList (lkBndr env1) bndrs - go (Case e b ty as) -- See Note [Empty case alternatives] - | null as = cm_ecase >.> lkE env e >=> lkT env ty - | otherwise = cm_case >.> lkE env e - >=> lkList (lkA (extendCME env b)) as - -xtE :: CmEnv -> CoreExpr -> XT a -> CoreMap a -> CoreMap a -xtE env e f EmptyCM = xtE env e f wrapEmptyCM -xtE env (Var v) f m = m { cm_var = cm_var m |> xtVar env v f } -xtE env (Type t) f m = m { cm_type = cm_type m |> xtT env t f } -xtE env (Coercion c) f m = m { cm_co = cm_co m |> xtC env c f } -xtE _ (Lit l) f m = m { cm_lit = cm_lit m |> xtLit l f } -xtE env (Cast e c) f m = m { cm_cast = cm_cast m |> xtE env e |>> - xtC env c f } -xtE env (Tick t e) f m = m { cm_tick = cm_tick m |> xtE env e |>> xtTickish t f } -xtE env (App e1 e2) f m = m { cm_app = cm_app m |> xtE env e2 |>> xtE env e1 f } -xtE env (Lam v e) f m = m { cm_lam = cm_lam m |> xtE (extendCME env v) e - |>> xtBndr env v f } -xtE env (Let (NonRec b r) e) f m = m { cm_letn = cm_letn m - |> xtE (extendCME env b) e - |>> xtE env r |>> xtBndr env b f } -xtE env (Let (Rec prs) e) f m = m { cm_letr = let (bndrs,rhss) = unzip prs - env1 = extendCMEs env bndrs - in cm_letr m - |> xtList (xtE env1) rhss - |>> xtE env1 e - |>> xtList (xtBndr env1) bndrs f } -xtE env (Case e b ty as) f m - | null as = m { cm_ecase = cm_ecase m |> xtE env e |>> xtT env ty f } - | otherwise = m { cm_case = cm_case m |> xtE env e - |>> let env1 = extendCME env b - in xtList (xtA env1) as f } - -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 :: CoreMap a - , am_data :: NameEnv (CoreMap a) - , am_lit :: LiteralMap (CoreMap a) } - -instance TrieMap AltMap where - type Key AltMap = CoreAlt - emptyTM = AM { am_deflt = emptyTM - , am_data = emptyNameEnv - , am_lit = emptyLiteralMap } - lookupTM = lkA emptyCME - alterTM = xtA emptyCME - foldTM = fdA - mapTM = mapA - -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 = mapNameEnv (mapTM f) adata - , am_lit = mapTM (mapTM f) alit } - -lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a -lkA env (DEFAULT, _, rhs) = am_deflt >.> lkE env rhs -lkA env (LitAlt lit, _, rhs) = am_lit >.> lkLit lit >=> lkE env rhs -lkA env (DataAlt dc, bs, rhs) = am_data >.> lkNamed dc >=> lkE (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 |> xtE env rhs f } -xtA env (LitAlt l, _, rhs) f m = m { am_lit = am_lit m |> xtLit l |>> xtE env rhs f } -xtA env (DataAlt d, bs, rhs) f m = m { am_data = am_data m |> xtNamed d - |>> xtE (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) -\end{code} - -%************************************************************************ -%* * - Coercions -%* * -%************************************************************************ - -\begin{code} -data CoercionMap a - = EmptyKM - | KM { km_refl :: RoleMap (TypeMap a) - , km_tc_app :: RoleMap (NameEnv (ListMap CoercionMap a)) - , km_app :: CoercionMap (CoercionMap a) - , km_forall :: CoercionMap (TypeMap a) - , km_var :: VarMap a - , km_axiom :: NameEnv (IntMap.IntMap (ListMap CoercionMap a)) - , km_univ :: RoleMap (TypeMap (TypeMap a)) - , km_sym :: CoercionMap a - , km_trans :: CoercionMap (CoercionMap a) - , km_nth :: IntMap.IntMap (CoercionMap a) - , km_left :: CoercionMap a - , km_right :: CoercionMap a - , km_inst :: CoercionMap (TypeMap a) - , km_sub :: CoercionMap a - , km_axiom_rule :: Map.Map FastString - (ListMap TypeMap (ListMap CoercionMap a)) - } - -wrapEmptyKM :: CoercionMap a -wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyTM - , km_app = emptyTM, km_forall = emptyTM - , km_var = emptyTM, km_axiom = emptyNameEnv - , km_univ = emptyTM, km_sym = emptyTM, km_trans = emptyTM - , km_nth = emptyTM, km_left = emptyTM, km_right = emptyTM - , km_inst = emptyTM, km_sub = emptyTM - , km_axiom_rule = emptyTM } - -instance TrieMap CoercionMap where - type Key CoercionMap = Coercion - emptyTM = EmptyKM - lookupTM = lkC emptyCME - alterTM = xtC emptyCME - foldTM = fdC - mapTM = mapC - -mapC :: (a->b) -> CoercionMap a -> CoercionMap b -mapC _ EmptyKM = EmptyKM -mapC f (KM { km_refl = krefl, km_tc_app = ktc - , km_app = kapp, km_forall = kforall - , km_var = kvar, km_axiom = kax - , km_univ = kuniv , km_sym = ksym, km_trans = ktrans - , km_nth = knth, km_left = kml, km_right = kmr - , km_inst = kinst, km_sub = ksub - , km_axiom_rule = kaxr }) - = KM { km_refl = mapTM (mapTM f) krefl - , km_tc_app = mapTM (mapNameEnv (mapTM f)) ktc - , km_app = mapTM (mapTM f) kapp - , km_forall = mapTM (mapTM f) kforall - , km_var = mapTM f kvar - , km_axiom = mapNameEnv (IntMap.map (mapTM f)) kax - , km_univ = mapTM (mapTM (mapTM f)) kuniv - , km_sym = mapTM f ksym - , km_trans = mapTM (mapTM f) ktrans - , km_nth = IntMap.map (mapTM f) knth - , km_left = mapTM f kml - , km_right = mapTM f kmr - , km_inst = mapTM (mapTM f) kinst - , km_sub = mapTM f ksub - , km_axiom_rule = mapTM (mapTM (mapTM f)) kaxr - } - -lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a -lkC env co m - | EmptyKM <- m = Nothing - | otherwise = go co m - where - go (Refl r ty) = km_refl >.> lookupTM r >=> lkT env ty - go (TyConAppCo r tc cs) = km_tc_app >.> lookupTM r >=> lkNamed tc >=> lkList (lkC env) cs - go (AxiomInstCo ax ind cs) = km_axiom >.> lkNamed ax >=> lookupTM ind >=> lkList (lkC env) cs - go (AppCo c1 c2) = km_app >.> lkC env c1 >=> lkC env c2 - go (TransCo c1 c2) = km_trans >.> lkC env c1 >=> lkC env c2 - go (UnivCo r t1 t2) = km_univ >.> lookupTM r >=> lkT env t1 >=> lkT env t2 - go (InstCo c t) = km_inst >.> lkC env c >=> lkT env t - go (ForAllCo v c) = km_forall >.> lkC (extendCME env v) c >=> lkBndr env v - go (CoVarCo v) = km_var >.> lkVar env v - go (SymCo c) = km_sym >.> lkC env c - go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c - go (LRCo CLeft c) = km_left >.> lkC env c - go (LRCo CRight c) = km_right >.> lkC env c - go (SubCo c) = km_sub >.> lkC env c - go (AxiomRuleCo co ts cs) = km_axiom_rule >.> - lookupTM (coaxrName co) >=> - lkList (lkT env) ts >=> - lkList (lkC env) cs - - -xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a -xtC env co f EmptyKM = xtC env co f wrapEmptyKM -xtC env (Refl r ty) f m = m { km_refl = km_refl m |> xtR r |>> xtT env ty f } -xtC env (TyConAppCo r tc cs) f m = m { km_tc_app = km_tc_app m |> xtR r |>> xtNamed tc |>> xtList (xtC env) cs f } -xtC env (AxiomInstCo ax ind cs) f m = m { km_axiom = km_axiom m |> xtNamed ax |>> xtInt ind |>> xtList (xtC env) cs f } -xtC env (AppCo c1 c2) f m = m { km_app = km_app m |> xtC env c1 |>> xtC env c2 f } -xtC env (TransCo c1 c2) f m = m { km_trans = km_trans m |> xtC env c1 |>> xtC env c2 f } -xtC env (UnivCo r t1 t2) f m = m { km_univ = km_univ m |> xtR r |>> xtT env t1 |>> xtT env t2 f } -xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f } -xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c - |>> xtBndr env v f } -xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f } -xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f } -xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f } -xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f } -xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f } -xtC env (SubCo c) f m = m { km_sub = km_sub m |> xtC env c f } -xtC env (AxiomRuleCo co ts cs) f m = m { km_axiom_rule = km_axiom_rule m - |> alterTM (coaxrName co) - |>> xtList (xtT env) ts - |>> xtList (xtC env) cs f} - -fdC :: (a -> b -> b) -> CoercionMap a -> b -> b -fdC _ EmptyKM = \z -> z -fdC k m = foldTM (foldTM k) (km_refl m) - . foldTM (foldTM (foldTM k)) (km_tc_app m) - . foldTM (foldTM k) (km_app m) - . foldTM (foldTM k) (km_forall m) - . foldTM k (km_var m) - . foldTM (foldTM (foldTM k)) (km_axiom m) - . foldTM (foldTM (foldTM k)) (km_univ m) - . foldTM k (km_sym m) - . foldTM (foldTM k) (km_trans m) - . foldTM (foldTM k) (km_nth m) - . foldTM k (km_left m) - . foldTM k (km_right m) - . foldTM (foldTM k) (km_inst m) - . foldTM k (km_sub m) - . foldTM (foldTM (foldTM k)) (km_axiom_rule m) - -\end{code} - -\begin{code} - -newtype RoleMap a = RM { unRM :: (IntMap.IntMap a) } - -instance TrieMap RoleMap where - type Key RoleMap = Role - emptyTM = RM emptyTM - lookupTM = lkR - alterTM = xtR - foldTM = fdR - mapTM = mapR - -lkR :: Role -> RoleMap a -> Maybe a -lkR Nominal = lookupTM 1 . unRM -lkR Representational = lookupTM 2 . unRM -lkR Phantom = lookupTM 3 . unRM - -xtR :: Role -> XT a -> RoleMap a -> RoleMap a -xtR Nominal f = RM . alterTM 1 f . unRM -xtR Representational f = RM . alterTM 2 f . unRM -xtR Phantom f = RM . alterTM 3 f . unRM - -fdR :: (a -> b -> b) -> RoleMap a -> b -> b -fdR f (RM m) = foldTM f m - -mapR :: (a -> b) -> RoleMap a -> RoleMap b -mapR f = RM . mapTM f . unRM - -\end{code} - - -%************************************************************************ -%* * - Types -%* * -%************************************************************************ - -\begin{code} -data TypeMap a - = EmptyTM - | TM { tm_var :: VarMap a - , tm_app :: TypeMap (TypeMap a) - , tm_fun :: TypeMap (TypeMap a) - , tm_tc_app :: NameEnv (ListMap TypeMap a) - , tm_forall :: TypeMap (BndrMap a) - , tm_tylit :: TyLitMap a - } - - -instance Outputable a => Outputable (TypeMap a) where - ppr m = text "TypeMap elts" <+> ppr (foldTypeMap (:) [] m) - -foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b -foldTypeMap k z m = fdT k m z - -emptyTypeMap :: TypeMap a -emptyTypeMap = EmptyTM - -lookupTypeMap :: TypeMap a -> Type -> Maybe a -lookupTypeMap cm t = lkT emptyCME t cm - --- Returns the type map entries that have keys starting with the given tycon. --- This only considers saturated applications (i.e. TyConApp ones). -lookupTypeMapTyCon :: TypeMap a -> TyCon -> [a] -lookupTypeMapTyCon EmptyTM _ = [] -lookupTypeMapTyCon TM { tm_tc_app = cs } tc = - case lookupUFM cs tc of - Nothing -> [] - Just xs -> foldTM (:) xs [] - -extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a -extendTypeMap m t v = xtT emptyCME t (\_ -> Just v) m - -wrapEmptyTypeMap :: TypeMap a -wrapEmptyTypeMap = TM { tm_var = emptyTM - , tm_app = EmptyTM - , tm_fun = EmptyTM - , tm_tc_app = emptyNameEnv - , tm_forall = EmptyTM - , tm_tylit = emptyTyLitMap } - -instance TrieMap TypeMap where - type Key TypeMap = Type - emptyTM = EmptyTM - lookupTM = lkT emptyCME - alterTM = xtT emptyCME - foldTM = fdT - mapTM = mapT - -mapT :: (a->b) -> TypeMap a -> TypeMap b -mapT _ EmptyTM = EmptyTM -mapT f (TM { tm_var = tvar, tm_app = tapp, tm_fun = tfun - , tm_tc_app = ttcapp, tm_forall = tforall, tm_tylit = tlit }) - = TM { tm_var = mapTM f tvar - , tm_app = mapTM (mapTM f) tapp - , tm_fun = mapTM (mapTM f) tfun - , tm_tc_app = mapNameEnv (mapTM f) ttcapp - , tm_forall = mapTM (mapTM f) tforall - , tm_tylit = mapTM f tlit } - ------------------ -lkT :: CmEnv -> Type -> TypeMap a -> Maybe a -lkT env ty m - | EmptyTM <- m = Nothing - | otherwise = go ty m - where - go ty | Just ty' <- coreView ty = go ty' - go (TyVarTy v) = tm_var >.> lkVar env v - go (AppTy t1 t2) = tm_app >.> lkT env t1 >=> lkT env t2 - go (FunTy t1 t2) = tm_fun >.> lkT env t1 >=> lkT env t2 - go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys - go (LitTy l) = tm_tylit >.> lkTyLit l - go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv - - ------------------ -xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a -xtT env ty f m - | EmptyTM <- m = xtT env ty f wrapEmptyTypeMap - | Just ty' <- coreView ty = xtT env ty' f m - -xtT env (TyVarTy v) f m = m { tm_var = tm_var m |> xtVar env v f } -xtT env (AppTy t1 t2) f m = m { tm_app = tm_app m |> xtT env t1 |>> xtT env t2 f } -xtT env (FunTy t1 t2) f m = m { tm_fun = tm_fun m |> xtT env t1 |>> xtT env t2 f } -xtT env (ForAllTy tv ty) f m = m { tm_forall = tm_forall m |> xtT (extendCME env tv) ty - |>> xtBndr env tv f } -xtT env (TyConApp tc tys) f m = m { tm_tc_app = tm_tc_app m |> xtNamed tc - |>> xtList (xtT env) tys f } -xtT _ (LitTy l) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } - -fdT :: (a -> b -> b) -> TypeMap a -> b -> b -fdT _ EmptyTM = \z -> z -fdT k m = foldTM k (tm_var m) - . foldTM (foldTM k) (tm_app m) - . foldTM (foldTM k) (tm_fun m) - . foldTM (foldTM k) (tm_tc_app m) - . foldTM (foldTM k) (tm_forall m) - . foldTyLit k (tm_tylit 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.fold l) (tlm_string m) - . flip (Map.fold l) (tlm_number m) -\end{code} - - -%************************************************************************ -%* * - Variables -%* * -%************************************************************************ - -\begin{code} -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 - ---------- Variable binders ------------- -type BndrMap = TypeMap - -lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a -lkBndr env v m = lkT env (varType v) m - -xtBndr :: CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a -xtBndr env v f = xtT env (varType v) f - ---------- Variable occurrence ------------- -data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable - , vm_fvar :: VarEnv a } -- Free variable - -instance TrieMap VarMap where - type Key VarMap = Var - emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyVarEnv } - 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 = mapVarEnv f fv } - -lkVar :: CmEnv -> Var -> VarMap a -> Maybe a -lkVar env v - | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv - | otherwise = vm_fvar >.> lkFreeVar 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 |> xtInt bv f } - | otherwise = m { vm_fvar = vm_fvar m |> xtFreeVar v f } - -fdVar :: (a -> b -> b) -> VarMap a -> b -> b -fdVar k m = foldTM k (vm_bvar m) - . foldTM k (vm_fvar m) - -lkFreeVar :: Var -> VarEnv a -> Maybe a -lkFreeVar var env = lookupVarEnv env var - -xtFreeVar :: Var -> XT a -> VarEnv a -> VarEnv a -xtFreeVar v f m = alterVarEnv f m v -\end{code} -- cgit v1.2.1