X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=d483b82897b746f0fc63e7874c1a8d7a5d6fd035;hb=98a74c9da8b10a3ba8fa2c261c2e26970c56a811;hp=c209cc81e56cd2bd473487db54f7300f72965778;hpb=3dea9c721725ca1030723fbed8bf6648913fc2fb;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index c209cc8..d483b82 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -11,7 +11,7 @@ module CoreUtils ( mkPiType, -- Taking expressions apart - findDefault, findAlt, + findDefault, findAlt, hasDefault, -- Properties of expressions exprType, coreAltsType, @@ -19,7 +19,7 @@ module CoreUtils ( exprIsValue,exprOkForSpeculation, exprIsBig, exprIsConApp_maybe, exprIsAtom, idAppIsBottom, idAppIsCheap, - exprArity, + exprArity, -- Expr transformation etaReduce, etaExpand, @@ -49,24 +49,22 @@ 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, applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy, - splitForAllTy_maybe, splitNewType_maybe + splitForAllTy_maybe, isForAllTy, eqType ) 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} @@ -187,23 +185,24 @@ mkInlineMe e = Note InlineMe e mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr) - = ASSERT( from_ty == to_ty2 ) + = ASSERT( from_ty `eqType` to_ty2 ) mkCoerce to_ty from_ty2 expr mkCoerce to_ty from_ty expr - | to_ty == from_ty = expr - | otherwise = ASSERT( from_ty == exprType expr ) - Note (Coerce to_ty from_ty) expr + | to_ty `eqType` from_ty = expr + | otherwise = ASSERT( from_ty `eqType` exprType expr ) + Note (Coerce to_ty from_ty) expr \end{code} \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} @@ -252,25 +251,31 @@ mkIfThenElse guard then_expr else_expr %* * %************************************************************************ +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} +hasDefault :: [CoreAlt] -> Bool +hasDefault ((DEFAULT,_,_) : alts) = True +hasDefault _ = False + 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) +findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) +findDefault alts = (alts, Nothing) findAlt :: AltCon -> [CoreAlt] -> CoreAlt findAlt con alts - = go alts + = case alts of + (deflt@(DEFAULT,_,_):alts) -> go alts deflt + other -> go alts panic_deflt + where - go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts)) - go (alt : alts) | matches alt = alt - | otherwise = go alts + panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts)) - matches (DEFAULT, _, _) = True - matches (con1, _, _) = con == con1 + go [] deflt = deflt + go (alt@(con1,_,_) : alts) deflt | con == con1 = alt + | otherwise = ASSERT( not (con1 == DEFAULT) ) + go alts deflt \end{code} @@ -304,9 +309,9 @@ exprIsTrivial (Var v) | otherwise = True exprIsTrivial (Type _) = True exprIsTrivial (Lit lit) = True -exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e +exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e exprIsTrivial (Note _ e) = exprIsTrivial e -exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body +exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body exprIsTrivial other = False exprIsAtom :: CoreExpr -> Bool @@ -315,6 +320,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} @@ -332,10 +338,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 @@ -382,8 +389,9 @@ 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 (Lam x e) = isRuntimeVar x || exprIsCheap e exprIsCheap (Case e _ alts) = exprIsCheap e && and [exprIsCheap rhs | (_,_,rhs) <- alts] -- Experimentally, treat (case x of ...) as cheap @@ -409,8 +417,8 @@ exprIsCheap other_expr -- because it certainly doesn't need to be shared! go (App f a) n_args args_cheap - | isTypeArg a = go f n_args args_cheap - | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap) + | not (isRuntimeArg a) = go f n_args args_cheap + | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap) go other n_args args_cheap = False @@ -419,7 +427,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 @@ -467,7 +475,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 @@ -479,8 +487,8 @@ exprOkForSpeculation other_expr other -> False go (App f a) n_args args_ok - | isTypeArg a = go f n_args args_ok - | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok) + | not (isRuntimeArg a) = go f n_args args_ok + | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok) go other n_args args_ok = False \end{code} @@ -504,7 +512,7 @@ idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args \end{code} @exprIsValue@ returns true for expressions that are certainly *already* -evaluated to WHNF. This is used to decide wether it's ok to change +evaluated to WHNF. This is used to decide whether it's ok to change case x of _ -> e ===> e and to decide whether it's safe to discard a `seq` @@ -517,16 +525,18 @@ as values, even if their arguments are non-trivial; map (...redex...) is a value Because `seq` on such things completes immediately -A worry: constructors with unboxed args: +A possible worry: constructors with unboxed args: C (f x :: Int#) -Suppose (f x) diverges; then C (f x) is not a value. +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 exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind -- copying them exprIsValue (Lit l) = True -exprIsValue (Lam b e) = isId b || exprIsValue e +exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e exprIsValue (Note _ e) = exprIsValue e exprIsValue other_expr = go other_expr 0 @@ -534,8 +544,8 @@ exprIsValue other_expr go (Var f) n_args = idAppIsValue f n_args go (App f a) n_args - | isTypeArg a = go f n_args - | otherwise = go f (n_args + 1) + | not (isRuntimeArg a) = go f n_args + | otherwise = go f (n_args + 1) go (Note _ f) n_args = go f n_args @@ -543,7 +553,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) @@ -554,8 +564,13 @@ 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) | Just con <- isDataConId_maybe fun, @@ -573,20 +588,6 @@ exprIsConApp_maybe expr 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} %************************************************************************ @@ -644,36 +645,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 @@ -681,15 +712,6 @@ exprEtaExpandArity e -- giving just -- f = \x -> e -- A Bad Idea - -min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest -min_zero (x:xs) = go x xs - where - go 0 xs = 0 -- Nothing beats zero - go min [] = min - go min (x:xs) | x < min = go x xs - | otherwise = go min xs - \end{code} @@ -713,10 +735,17 @@ 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 + | n == 0 && + -- The ILX code generator requires eta expansion for type arguments + -- too, but alas the 'n' doesn't tell us how many of them there + -- may be. So we eagerly eta expand any big lambdas, and just + -- cross our fingers about possible loss of sharing in the + -- ILX case. + -- The Right Thing is probably to make 'arity' include + -- type variables throughout the compiler. (ToDo.) + not (isForAllTy ty) + -- Saturated, so nothing to do = expr | otherwise -- An unsaturated constructor or primop; eta expand it @@ -732,13 +761,48 @@ etaExpand n us expr ty (us1, us2) = splitUniqSupply us uniq = uniqFromSupply us1 - ; Nothing -> - - case splitNewType_maybe ty of { - Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ; - - Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr - }}} + ; Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr + }} +\end{code} + + +exprArity is a cheap-and-cheerful version of exprEtaExpandArity. +It tells how many things the expression can be applied to before doing +any work. It doesn't look inside cases, lets, etc. The idea is that +exprEtaExpandArity will do the hard work, leaving something that's easy +for exprArity to grapple with. In particular, Simplify uses exprArity to +compute the ArityInfo for the Id. + +Originally I thought that it was enough just to look for top-level lambdas, but +it isn't. I've seen this + + foo = PrelBase.timesInt + +We want foo to get arity 2 even though the eta-expander will leave it +unchanged, in the expectation that it'll be inlined. But occasionally it +isn't, because foo is blacklisted (used in a rule). + +Similarly, see the ok_note check in exprEtaExpandArity. So + f = __inline_me (\x -> e) +won't be eta-expanded. + +And in any case it seems more robust to have exprArity be a bit more intelligent. + +\begin{code} +exprArity :: CoreExpr -> Int +exprArity e = go e + 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) | exprIsCheap a = (go f - 1) `max` 0 + -- Important! f (fac x) does not have arity 2, + -- even if f does! + -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is + -- unknown, hence arity 0 + go (Var v) = idArity v + go _ = 0 \end{code} @@ -757,7 +821,7 @@ 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 == t2 +cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2 cheapEqExpr (App f1 a1) (App f2 a2) = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 @@ -777,6 +841,9 @@ exprIsBig other = True \begin{code} eqExpr :: CoreExpr -> CoreExpr -> Bool -- Works ok at more general type, but only needed at CoreExpr + -- Used in rule matching, so when we find a type we use + -- eqTcType, which doesn't look through newtypes + -- [And it doesn't risk falling into a black hole either.] eqExpr e1 e2 = eq emptyVarEnv e1 e2 where @@ -807,7 +874,7 @@ eqExpr e1 e2 env' = extendVarEnv env v1 v2 eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2 - eq env (Type t1) (Type t2) = t1 == t2 + eq env (Type t1) (Type t2) = t1 `eqType` t2 eq env e1 e2 = False eq_list env [] [] = True @@ -818,7 +885,7 @@ eqExpr e1 e2 eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2 - eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2 + eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2 eq_note env InlineCall InlineCall = True eq_note env other1 other2 = False \end{code}