X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=70e1db7e2aaf7d2efe4cf4a606f0cbb8b784d261;hb=841e81e28f8cc711f624fdca122219a5bbde2fae;hp=66d34b1e84bc99b6d61162fcd480c46a9d5de32d;hpb=9e6ca39b5e90b7a4acc755e3e95cc3ef60940070;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 66d34b1..70e1db7 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -25,12 +25,14 @@ module CoreUtils ( -- * Properties of expressions exprType, coreAltType, coreAltsType, - exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable, + exprIsDupable, exprIsTrivial, exprIsBottom, + exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun, exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike, rhsIsStatic, isCheapApp, isExpandableApp, -- * Expression and bindings size coreBindsSize, exprSize, + CoreStats(..), coreBindsStats, -- * Hashing hashExpr, @@ -55,9 +57,6 @@ import SrcLoc import VarEnv import VarSet import Name -#if mingw32_TARGET_OS -import Packages -#endif import Literal import DataCon import PrimOp @@ -71,7 +70,6 @@ import CostCentre import Unique import Outputable import TysPrim -import PrelNames( absentErrorIdKey ) import FastString import Maybes import Util @@ -426,6 +424,25 @@ exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body exprIsTrivial _ = False \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 (Note _ e) = go n e + go n (Cast e _) = go n e + go n (Let _ e) = go n e + go _ _ = False +\end{code} + %************************************************************************ %* * @@ -448,22 +465,27 @@ Note [exprIsDupable] \begin{code} exprIsDupable :: CoreExpr -> Bool -exprIsDupable (Type _) = True -exprIsDupable (Var _) = True -exprIsDupable (Lit lit) = litIsDupable lit -exprIsDupable (Note _ e) = exprIsDupable e -exprIsDupable (Cast e _) = exprIsDupable e -exprIsDupable expr - = go expr 0 +exprIsDupable e + = isJust (go dupAppSize e) where - go (Var _) _ = True - go (App f a) n_args = n_args < dupAppSize - && exprIsDupable a - && go f (n_args+1) - go _ _ = False + go :: Int -> CoreExpr -> Maybe Int + go n (Type {}) = Just n + go n (Var {}) = decrement n + go n (Note _ 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 lit = decrement n + go _ _ = Nothing + + decrement :: Int -> Maybe Int + decrement 0 = Nothing + decrement n = Just (n-1) dupAppSize :: Int -dupAppSize = 4 -- Size of application we are prepared to duplicate +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} %************************************************************************ @@ -516,8 +538,8 @@ exprIsCheap = exprIsCheap' isCheapApp exprIsExpandable :: CoreExpr -> Bool exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes - -exprIsCheap' :: (Id -> Int -> Bool) -> CoreExpr -> Bool +type CheapAppFun = Id -> Int -> Bool +exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool exprIsCheap' _ (Lit _) = True exprIsCheap' _ (Type _) = True exprIsCheap' _ (Var _) = True @@ -545,13 +567,14 @@ 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 go (Var f) args - = case idDetails f of + = case idDetails f of RecSelId {} -> go_sel args ClassOpId {} -> go_sel args PrimOpId op -> go_primop op args @@ -585,12 +608,12 @@ exprIsCheap' good_app other_expr -- Applications and variables -- 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) -isCheapApp :: Id -> Int -> Bool +isCheapApp :: CheapAppFun isCheapApp fn n_val_args = isDataConWorkId fn || n_val_args < idArity fn -isExpandableApp :: Id -> Int -> Bool +isExpandableApp :: CheapAppFun isExpandableApp fn n_val_args = isConLikeId fn || n_val_args < idArity fn @@ -633,6 +656,11 @@ it's applied only to dictionaries. -- -- * 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: -- -- * The expression guarantees to terminate, @@ -658,9 +686,14 @@ it's applied only to dictionaries. exprOkForSpeculation :: CoreExpr -> Bool exprOkForSpeculation (Lit _) = True exprOkForSpeculation (Type _) = True - -- Tick boxes are *not* suitable for speculation -exprOkForSpeculation (Var v) = isUnLiftedType (idType v) - && not (isTickBoxOp v) + +exprOkForSpeculation (Var v) + | isTickBoxOp v = False -- Tick boxes are *not* suitable for speculation + | otherwise = isUnLiftedType (idType v) -- c.f. the Var case of exprIsHNF + || isDataConWorkId v -- Nullary constructors + || idArity v > 0 -- Functions + || isEvaldUnfolding (idUnfolding v) -- Let-bound values + exprOkForSpeculation (Note _ e) = exprOkForSpeculation e exprOkForSpeculation (Cast e _) = exprOkForSpeculation e @@ -670,10 +703,7 @@ exprOkForSpeculation (Case e _ _ alts) exprOkForSpeculation other_expr = case collectArgs other_expr of - (Var f, args) | f `hasKey` absentErrorIdKey -- Note [Absent error Id] - -> all exprOkForSpeculation args -- in WwLib - | otherwise - -> spec_ok (idDetails f) args + (Var f, args) -> spec_ok (idDetails f) args _ -> False where @@ -689,13 +719,16 @@ exprOkForSpeculation other_expr -- 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 = primOpOkForSpeculation op && all exprOkForSpeculation args -- A bit conservative: we don't really need -- to care about lazy arguments, but this is easy - spec_ok (DFunId new_type) _ = not new_type + spec_ok (DFunId _ new_type) _ = not new_type -- DFuns terminate, unless the dict is implemented with a newtype -- in which case they may not @@ -717,7 +750,6 @@ 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 @@ -725,7 +757,7 @@ 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: +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) @@ -735,8 +767,8 @@ If exprOkForSpeculation doesn't look through case expressions, you get this: \ (ww :: GHC.Prim.Int#) -> case ww of ds { __DEFAULT -> case (case <# ds 5 of _ { - GHC.Bool.False -> lvl1; - GHC.Bool.True -> lvl}) + GHC.Types.False -> lvl1; + GHC.Types.True -> lvl}) of _ { __DEFAULT -> T.$wfoo (GHC.Prim.-# ds_XkE 1) }; 0 -> 0 @@ -744,6 +776,27 @@ If exprOkForSpeculation doesn't look through case expressions, you get this: The inner case is redundant, and should be nuked. +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 + %************************************************************************ %* * @@ -1068,6 +1121,7 @@ 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 @@ -1102,6 +1156,62 @@ altSize :: CoreAlt -> Int altSize (c,bs,e) = c `seq` varsSize bs + exprSize e \end{code} +\begin{code} +data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int } + +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 (App f (Type t))= tyCoStats (exprType f) t +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 (Note _ e) = exprStats e +exprStats (Type ty) = zeroCS { cs_ty = typeSize ty } + -- Ugh (might be a co) + +altStats :: CoreAlt -> CoreStats +altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r + +tyCoStats :: Type -> Type -> CoreStats +tyCoStats fun_ty arg + = case splitForAllTy_maybe fun_ty of + Just (tv,_) | isCoVar tv -> coStats arg + _ -> tyStats arg + +tyStats :: Type -> CoreStats +tyStats ty = zeroCS { cs_ty = typeSize ty } + +coStats :: Coercion -> CoreStats +coStats co = zeroCS { cs_co = typeSize co } +\end{code} %************************************************************************ %* * @@ -1396,11 +1506,9 @@ rhsIsStatic _is_dynamic_name rhs = is_static False rhs 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 _ (Note (SCC _) _) = False - is_static in_arg (Note _ e) = is_static in_arg e - is_static in_arg (Cast e _) = is_static in_arg e + is_static False (Lam b e) = isRuntimeVar b || is_static False e + is_static in_arg (Note n e) = notSccNote n && is_static in_arg e + is_static in_arg (Cast e _) = is_static in_arg e is_static _ (Lit lit) = case lit of @@ -1441,11 +1549,9 @@ rhsIsStatic _is_dynamic_name rhs = is_static False rhs -- x = D# (1.0## /## 2.0##) -- can't float because /## can fail. - go (Note (SCC _) _) _ = False - go (Note _ f) n_val_args = go f n_val_args - go (Cast e _) n_val_args = go e n_val_args - - go _ _ = False + go (Note n f) n_val_args = notSccNote 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