X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=9761db150aa70a73597f79ba4ee8706168287ac4;hb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;hp=56a84a5ab39d258d186a81bed0c28ff9e054b8a2;hpb=72462499b891d5779c19f3bda03f96e24f9554ae;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 56a84a5..9761db1 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -26,7 +26,7 @@ module CoreUtils ( -- * Properties of expressions exprType, coreAltType, coreAltsType, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable, - exprIsHNF,exprOkForSpeculation, exprIsBig, + exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike, rhsIsStatic, -- * Expression and bindings size @@ -210,7 +210,7 @@ mkCoerce co expr -- if to_ty `coreEqType` from_ty -- then expr -- else - ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindPredTy co)) + WARN(not (from_ty `coreEqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co)) (Cast expr co) \end{code} @@ -377,10 +377,12 @@ filters down the matching alternatives in Simplify.rebuildCase. %************************************************************************ %* * - Figuring out things about expressions + 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 @@ -421,6 +423,14 @@ exprIsTrivial _ = 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. @@ -452,6 +462,14 @@ dupAppSize :: Int dupAppSize = 4 -- Size of application we are prepared to duplicate \end{code} +%************************************************************************ +%* * + exprIsCheap, exprIsExpandable +%* * +%************************************************************************ + +Note [exprIsCheap] +~~~~~~~~~~~~~~~~~~ @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 @@ -489,17 +507,20 @@ exprIsCheap' is_conlike (Note _ e) = exprIsCheap' is_conlike e exprIsCheap' is_conlike (Cast e _) = exprIsCheap' is_conlike e exprIsCheap' is_conlike (Lam x e) = isRuntimeVar x || exprIsCheap' is_conlike e + exprIsCheap' is_conlike (Case e _ _ alts) = exprIsCheap' is_conlike e && - and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts] + and [exprIsCheap' is_conlike 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' is_conlike (Let (NonRec x _) e) | isUnLiftedType (idType x) = exprIsCheap' is_conlike e | otherwise = False - -- strict lets always have cheap right hand sides, - -- and do no allocation. + -- Strict lets always have cheap right hand sides, + -- and do no allocation, so just look at the body + -- Non-strict lets do allocation so we don't treat them as cheap exprIsCheap' is_conlike other_expr -- Applications and variables = go other_expr [] @@ -554,6 +575,12 @@ exprIsExpandable :: CoreExpr -> Bool exprIsExpandable = exprIsCheap' isConLikeId -- See Note [CONLIKE pragma] in BasicTypes \end{code} +%************************************************************************ +%* * + exprOkForSpeculation +%* * +%************************************************************************ + \begin{code} -- | 'exprOkForSpeculation' returns True of an expression that is: -- @@ -639,41 +666,27 @@ isDivOp DoubleDivOp = True isDivOp _ = False \end{code} -\begin{code} -{- Never used -- omitting --- | True of expressions that are guaranteed to diverge upon execution -exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom -exprIsBottom e = go 0 e - where - -- n is the number of args - go n (Note _ e) = go n e - go n (Cast e _) = go n e - go n (Let _ e) = go n e - go _ (Case e _ _ _) = go 0 e -- Just check the scrut - go n (App e _) = go (n+1) e - go n (Var v) = idAppIsBottom v n - go _ (Lit _) = False - go _ (Lam _ _) = False - go _ (Type _) = False - -idAppIsBottom :: Id -> Int -> Bool -idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args --} -\end{code} +%************************************************************************ +%* * + exprIsHNF, exprIsConLike +%* * +%************************************************************************ \begin{code} - --- | This returns true for expressions that are certainly /already/ +-- Note [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: +-- 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 @@ -682,7 +695,7 @@ idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args -- > (:) (f x) (map f xs) -- > map (...redex...) -- --- Because 'seq' on such things completes immediately. +-- because 'seq' on such things completes immediately. -- -- For unlifted argument types, we have to be careful: -- @@ -692,36 +705,62 @@ idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args -- 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 (Var v) -- NB: There are no value args at this point - = isDataConWorkId v -- Catches nullary constructors, +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 - || isEvaldUnfolding (idUnfolding v) + || 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 - -- A worry: what if an Id's unfolding is just itself: - -- then we could get an infinite loop... - -exprIsHNF (Lit _) = True -exprIsHNF (Type _) = True -- Types are honorary Values; - -- we don't mind copying them -exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e -exprIsHNF (Note _ e) = exprIsHNF e -exprIsHNF (Cast e _) = exprIsHNF e -exprIsHNF (App e (Type _)) = exprIsHNF e -exprIsHNF (App e a) = app_is_value e [a] -exprIsHNF _ = 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 - || isDataConWorkId fun -- or data constructor -app_is_value (Note _ 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 + -- 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 (Lam b e) = isRuntimeVar b || is_hnf_like e + is_hnf_like (Note _ e) = is_hnf_like e + is_hnf_like (Cast e _) = is_hnf_like e + is_hnf_like (App e (Type _)) = 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 (Note _ 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 \end{code} + +%************************************************************************ +%* * + Instantiating data constructors +%* * +%************************************************************************ + These InstPat functions go here to avoid circularity between DataCon and Id \begin{code}