X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=7241e089948a23d65b941f64b3f6e4f6dbb74cfe;hb=f16228e47dbaf4c5eb710bf507b3b61bc5ad7122;hp=f0649d1d2034fd05b8ffb48b8ac5092792aee1d9;hpb=1703fe03e209e9d1f11c19a2b05fd4f0fd3d28f0;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index f0649d1..7241e08 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -10,6 +10,9 @@ module CoreUtils ( bindNonRec, mkIfThenElse, mkAltExpr, mkPiType, + -- Taking expressions apart + findDefault, findAlt, + -- Properties of expressions exprType, coreAltsType, exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, @@ -46,14 +49,13 @@ import VarEnv import Name ( hashName ) import Literal ( hashLiteral, literalType, litIsDupable ) import DataCon ( DataCon, dataConRepArity ) -import PrimOp ( primOpOkForSpeculation, primOpIsCheap, - primOpIsDupable ) -import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo, - mkWildId, idArity, idName, idUnfolding, idInfo, - isDataConId_maybe, isPrimOpId_maybe, mkSysLocal, hasNoBinding +import PrimOp ( primOpOkForSpeculation, primOpIsCheap ) +import Id ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo, + mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda, + isDataConId_maybe, mkSysLocal, hasNoBinding ) import IdInfo ( LBVarInfo(..), - IdFlavour(..), + GlobalIdDetails(..), megaSeqIdInfo ) import Demand ( appIsBottom ) import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, @@ -63,7 +65,6 @@ import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply ) -import Maybes ( maybeToBool ) import Outputable import TysPrim ( alphaTy ) -- Debugging only \end{code} @@ -196,11 +197,12 @@ mkCoerce to_ty from_ty expr \begin{code} mkSCC :: CostCentre -> Expr b -> Expr b -- Note: Nested SCC's *are* preserved for the benefit of - -- cost centre stack profiling (Durham) - -mkSCC cc (Lit lit) = Lit lit -mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda -mkSCC cc expr = Note (SCC cc) expr + -- cost centre stack profiling +mkSCC cc (Lit lit) = Lit lit +mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda +mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e) +mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes +mkSCC cc expr = Note (SCC cc) expr \end{code} @@ -242,6 +244,35 @@ mkIfThenElse guard then_expr else_expr (DataAlt falseDataCon, [], else_expr) ] \end{code} + +%************************************************************************ +%* * +\subsection{Taking expressions apart} +%* * +%************************************************************************ + + +\begin{code} +findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr) +findDefault [] = ([], Nothing) +findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args ) + ([], Just rhs) +findDefault (alt : alts) = case findDefault alts of + (alts', deflt) -> (alt : alts', deflt) + +findAlt :: AltCon -> [CoreAlt] -> CoreAlt +findAlt con alts + = go alts + where + go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts)) + go (alt : alts) | matches alt = alt + | otherwise = go alts + + matches (DEFAULT, _, _) = True + matches (con1, _, _) = con == con1 +\end{code} + + %************************************************************************ %* * \subsection{Figuring out things about expressions} @@ -283,6 +314,7 @@ exprIsAtom :: CoreExpr -> Bool exprIsAtom (Var v) = True -- primOpIsDupable? exprIsAtom (Lit lit) = True exprIsAtom (Type ty) = True +exprIsAtom (Note (SCC _) e) = False exprIsAtom (Note _ e) = exprIsAtom e exprIsAtom other = False \end{code} @@ -300,10 +332,11 @@ exprIsAtom other = False \begin{code} -exprIsDupable (Type _) = True -exprIsDupable (Var v) = True -exprIsDupable (Lit lit) = litIsDupable lit -exprIsDupable (Note _ e) = exprIsDupable e +exprIsDupable (Type _) = True +exprIsDupable (Var v) = True +exprIsDupable (Lit lit) = litIsDupable lit +exprIsDupable (Note InlineMe e) = True +exprIsDupable (Note _ e) = exprIsDupable e exprIsDupable expr = go expr 0 where @@ -350,6 +383,7 @@ exprIsCheap :: CoreExpr -> Bool exprIsCheap (Lit lit) = True exprIsCheap (Type _) = True exprIsCheap (Var _) = True +exprIsCheap (Note InlineMe e) = True exprIsCheap (Note _ e) = exprIsCheap e exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e exprIsCheap (Case e _ alts) = exprIsCheap e && @@ -387,7 +421,7 @@ idAppIsCheap id n_val_args | n_val_args == 0 = True -- Just a type application of -- a variable (f t1 t2 t3) -- counts as WHNF - | otherwise = case idFlavour id of + | otherwise = case globalIdDetails id of DataConId _ -> True RecordSelId _ -> True -- I'm experimenting with making record selection -- look cheap, so we will substitute it inside a @@ -435,7 +469,7 @@ exprOkForSpeculation other_expr = go other_expr 0 True where go (Var f) n_args args_ok - = case idFlavour f of + = case globalIdDetails f of DataConId _ -> True -- The strictness of the constructor has already -- been expressed by its "wrapper", so we don't need -- to take the arguments into account @@ -477,7 +511,19 @@ evaluated to WHNF. This is used to decide wether it's ok to change and to decide whether it's safe to discard a `seq` -So, it does *not* treat variables as evaluated, unless they say they are +So, it does *not* treat variables as evaluated, unless they say they are. + +But it *does* treat partial applications and constructor applications +as values, even if their arguments are non-trivial; + e.g. (:) (f x) (map f xs) is a value + map (...redex...) is a value +Because `seq` on such things completes immediately + +A possible worry: constructors with unboxed args: + C (f x :: Int#) +Suppose (f x) diverges; then C (f x) is not a value. True, but +this form is illegal (see the invariants in CoreSyn). Args of unboxed +type must be ok-for-speculation (or trivial). \begin{code} exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP @@ -501,7 +547,7 @@ exprIsValue other_expr idAppIsValue :: Id -> Int -> Bool idAppIsValue id n_val_args - = case idFlavour id of + = case globalIdDetails id of DataConId _ -> True PrimOpId _ -> n_val_args < idArity id other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id) @@ -512,40 +558,30 @@ idAppIsValue id n_val_args \begin{code} exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) -exprIsConApp_maybe expr - = analyse (collectArgs expr) +exprIsConApp_maybe (Note InlineMe expr) = exprIsConApp_maybe expr + -- We ignore InlineMe notes in case we have + -- x = __inline_me__ (a,b) + -- All part of making sure that INLINE pragmas never hurt + -- Marcin tripped on this one when making dictionaries more inlinable + +exprIsConApp_maybe expr = analyse (collectArgs expr) where analyse (Var fun, args) - | maybeToBool maybe_con_app = maybe_con_app - where - maybe_con_app = case isDataConId_maybe fun of - Just con | length args >= dataConRepArity con - -- Might be > because the arity excludes type args - -> Just (con, args) - other -> Nothing + | Just con <- isDataConId_maybe fun, + length args >= dataConRepArity con + -- Might be > because the arity excludes type args + = Just (con,args) + -- Look through unfoldings, but only cheap ones, because + -- we are effectively duplicating the unfolding analyse (Var fun, []) - = case maybeUnfoldingTemplate (idUnfolding fun) of - Nothing -> Nothing - Just unf -> exprIsConApp_maybe unf + | let unf = idUnfolding fun, + isCheapUnfolding unf + = exprIsConApp_maybe (unfoldingTemplate unf) analyse other = Nothing \end{code} -The arity of an expression (in the code-generator sense, i.e. the -number of lambdas at the beginning). - -\begin{code} -exprArity :: CoreExpr -> Int -exprArity (Lam x e) - | isTyVar x = exprArity e - | otherwise = 1 + exprArity e -exprArity (Note _ e) - -- Ignore coercions. Top level sccs are removed by the final - -- profiling pass, so we ignore those too. - = exprArity e -exprArity _ = 0 -\end{code} %************************************************************************ @@ -603,36 +639,66 @@ exprEtaExpandArity :: CoreExpr -> (Int, Bool) -- case x of p -> \s -> ... -- because for I/O ish things we really want to get that \s to the top. -- We are prepared to evaluate x each time round the loop in order to get that --- Hence "generous" arity +-- +-- Consider let x = expensive in \y z -> E +-- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda +-- +-- Hence the list of Bools returned by go1 +-- NB: this is particularly important/useful for IO state +-- transformers, where we often get +-- let x = E in \ s -> ... +-- and the \s is a real-world state token abstraction. Such +-- abstractions are almost invariably 1-shot, so we want to +-- pull the \s out, past the let x=E. +-- The hack is in Id.isOneShotLambda exprEtaExpandArity e = go 0 e where + go :: Int -> CoreExpr -> (Int,Bool) go ar (Lam x e) | isId x = go (ar+1) e | otherwise = go ar e go ar (Note n e) | ok_note n = go ar e go ar other = (ar + ar', ar' == 0) where - ar' = go1 other `max` 0 - - go1 (Var v) = idArity v - go1 (Lam x e) | isId x = go1 e + 1 - | otherwise = go1 e - go1 (Note n e) | ok_note n = go1 e - go1 (App f (Type _)) = go1 f - go1 (App f a) | exprIsCheap a = go1 f - 1 - go1 (Case scrut _ alts) - | exprIsCheap scrut = min_zero [go1 rhs | (_,_,rhs) <- alts] - go1 (Let b e) - | all exprIsCheap (rhssOfBind b) = go1 e - - go1 other = 0 + ar' = length (go1 other) + + go1 :: CoreExpr -> [Bool] + -- (go1 e) = [b1,..,bn] + -- means expression can be rewritten \x_b1 -> ... \x_bn -> body + -- where bi is True <=> the lambda is one-shot + + go1 (Note n e) | ok_note n = go1 e + go1 (Var v) = replicate (idArity v) False -- When the type of the Id + -- encodes one-shot-ness, use + -- the idinfo here + + -- Lambdas; increase arity + go1 (Lam x e) | isId x = isOneShotLambda x : go1 e + | otherwise = go1 e + + -- Applications; decrease arity + go1 (App f (Type _)) = go1 f + go1 (App f a) = case go1 f of + (one_shot : xs) | one_shot || exprIsCheap a -> xs + other -> [] + + -- Case/Let; keep arity if either the expression is cheap + -- or it's a 1-shot lambda + go1 (Case scrut _ alts) = case foldr1 (zipWith (&&)) [go1 rhs | (_,_,rhs) <- alts] of + xs@(one_shot : _) | one_shot || exprIsCheap scrut -> xs + other -> [] + go1 (Let b e) = case go1 e of + xs@(one_shot : _) | one_shot || all exprIsCheap (rhssOfBind b) -> xs + other -> [] + + go1 other = [] ok_note (Coerce _ _) = True ok_note InlineCall = True ok_note other = False -- Notice that we do not look through __inline_me__ - -- This one is a bit more surprising, but consider + -- This may seem surprising, but consider -- f = _inline_me (\x -> e) -- We DO NOT want to eta expand this to -- f = \x -> (_inline_me (\x -> e)) x @@ -672,8 +738,6 @@ etaExpand :: Int -- Add this number of value args -- would return -- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y) --- (case x of { I# x -> /\ a -> coerce T E) - etaExpand n us expr ty | n == 0 -- Saturated, so nothing to do = expr @@ -701,6 +765,42 @@ etaExpand n us expr ty \end{code} +exprArity is a cheap-and-cheerful version of exprEtaExpandArity. +It tells how many things the expression can be applied to before doing +any work. It doesn't look inside cases, lets, etc. The idea is that +exprEtaExpandArity will do the hard work, leaving something that's easy +for exprArity to grapple with. In particular, Simplify uses exprArity to +compute the ArityInfo for the Id. + +Originally I thought that it was enough just to look for top-level lambdas, but +it isn't. I've seen this + + foo = PrelBase.timesInt + +We want foo to get arity 2 even though the eta-expander will leave it +unchanged, in the expectation that it'll be inlined. But occasionally it +isn't, because foo is blacklisted (used in a rule). + +Similarly, see the ok_note check in exprEtaExpandArity. So + f = __inline_me (\x -> e) +won't be eta-expanded. + +And in any case it seems more robust to have exprArity be a bit more intelligent. + +\begin{code} +exprArity :: CoreExpr -> Int +exprArity e = go e `max` 0 + where + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Note _ e) = go e + go (App e (Type t)) = go e + go (App f a) = go f - 1 + go (Var v) = idArity v + go _ = 0 +\end{code} + + %************************************************************************ %* * \subsection{Equality}