X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=c901fc2ef044f01241898a3e87e2efcdc763c07e;hp=1a217043262624cd7e5c518a8f108f7e0dcb2087;hb=c406b5bde899dd2b28e5239937c909d675bca356;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 1a21704..c901fc2 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -25,7 +25,8 @@ 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, @@ -55,10 +56,6 @@ import SrcLoc import VarEnv import VarSet import Name -import Module -#if mingw32_TARGET_OS -import Packages -#endif import Literal import DataCon import PrimOp @@ -426,6 +423,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 +464,24 @@ 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 = 6 -- Size of term we are prepared to duplicate \end{code} %************************************************************************ @@ -516,8 +534,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 +563,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 +604,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 +652,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 +682,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 @@ -686,13 +715,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 @@ -714,7 +746,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 @@ -722,7 +753,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) @@ -732,8 +763,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 @@ -741,6 +772,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 + %************************************************************************ %* * @@ -1227,18 +1279,55 @@ There are some particularly delicate points here: 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 + = go (reverse bndrs) body (IdCo (exprType body)) where incoming_arity = count isId bndrs - go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round - go [] fun | ok_fun fun = Just fun -- Success! - go _ _ = Nothing -- Failure! + go :: [Var] -- Binders, innermost first, types [a3,a2,a1] + -> CoreExpr -- Of type tr + -> CoercionI -- 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 = Just (mkCoerceI co fun) - -- Note [Eta reduction conditions] + 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 ty)) | not (any (`elemVarSet` tyVarsOfType ty) bndrs) = ok_fun fun @@ -1247,17 +1336,37 @@ tryEtaReduce bndrs body && (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 && isLoopBreaker (idOccInfo fun) = 0 | otherwise = idArity fun + --------------- ok_lam v = isTyCoVar v || isDictId v - ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg + --------------- + ok_arg :: Var -- Of type bndr_t + -> CoreExpr -- Of type arg_t + -> CoercionI -- Of kind (t1~t2) + -> Maybe CoercionI -- 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 (mkForAllTyCoI tv co) + ok_arg bndr (Var v) co + | bndr == v = Just (mkFunTyCoI (IdCo (idType bndr)) co) + ok_arg bndr (Cast (Var v) co_arg) co + | bndr == v = Just (mkFunTyCoI (ACo (mkSymCoercion 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} + %************************************************************************ %* * \subsection{Determining non-updatable right-hand-sides} @@ -1276,7 +1385,7 @@ 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 :: PackageId -> CoreExpr -> Bool +rhsIsStatic :: (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 @@ -1331,16 +1440,14 @@ rhsIsStatic :: PackageId -> CoreExpr -> Bool -- -- c) don't look through unfolding of f in (f x). -rhsIsStatic _this_pkg rhs = is_static False rhs +rhsIsStatic _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 _ (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 @@ -1359,7 +1466,7 @@ rhsIsStatic _this_pkg rhs = is_static False rhs where go (Var f) n_val_args #if mingw32_TARGET_OS - | not (isDllName _this_pkg (idName f)) + | not (_is_dynamic_name (idName f)) #endif = saturated_data_con f n_val_args || (in_arg && n_val_args == 0) @@ -1381,11 +1488,9 @@ rhsIsStatic _this_pkg 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