From c01e472e205f09e6cdadc1c878263998f637bc8d Mon Sep 17 00:00:00 2001 From: Roman Leshchinskiy Date: Wed, 4 Nov 2009 14:28:36 +0000 Subject: [PATCH] Consider variables with conlike unfoldings interesting In this expression: let x = f (g e1) in e2 the simplifier will inline f if it thinks that (g e1) is an interesting argument. Until now, this was essentially the case if g was a data constructor - we'd inline f in the hope that it will inspect and hence eliminate the constructor application. This patch extends this mechanism to CONLIKE functions. We consider (g e1) interesting if g is CONLIKE and inline f in the hope that this will allow rewrite rules to match. --- compiler/coreSyn/CoreSyn.lhs | 16 +++++++-- compiler/coreSyn/CoreUnfold.lhs | 5 +-- compiler/coreSyn/CoreUtils.lhs | 76 ++++++++++++++++++++++++--------------- compiler/coreSyn/PprCore.lhs | 4 ++- 4 files changed, 67 insertions(+), 34 deletions(-) diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 01e2be7..b6e7313 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -45,7 +45,7 @@ module CoreSyn ( unfoldingTemplate, setUnfoldingTemplate, maybeUnfoldingTemplate, otherCons, unfoldingArity, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, - isExpandableUnfolding, + isExpandableUnfolding, isConLikeUnfolding, isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, isStableUnfolding, canUnfold, neverUnfoldGuidance, @@ -413,6 +413,8 @@ data Unfolding uf_is_top :: Bool, -- True <=> top level binding uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard a `seq` on -- this variable + uf_is_conlike :: Bool, -- True <=> application of constructor or CONLIKE function + -- Cached version of exprIsConLike uf_is_cheap :: Bool, -- True <=> doesn't waste (much) work to expand inside an inlining -- Cached version of exprIsCheap uf_expandable :: Bool, -- True <=> can expand in RULE matching @@ -496,8 +498,9 @@ mkOtherCon = OtherCon seqUnfolding :: Unfolding -> () seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, uf_is_value = b1, uf_is_cheap = b2, - uf_expandable = b3, uf_arity = a, uf_guidance = g}) - = seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` seqGuidance g + uf_expandable = b3, uf_is_conlike = b4, + uf_arity = a, uf_guidance = g}) + = seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g seqUnfolding _ = () @@ -541,6 +544,13 @@ isEvaldUnfolding (OtherCon _) = True isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald isEvaldUnfolding _ = False +-- | @True@ if the unfolding is a constructor application, the application +-- of a CONLIKE function or 'OtherCon' +isConLikeUnfolding :: Unfolding -> Bool +isConLikeUnfolding (OtherCon _) = True +isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con +isConLikeUnfolding _ = False + -- | Is the thing we will unfold into certainly cheap? isCheapUnfolding :: Unfolding -> Bool isCheapUnfolding (CoreUnfolding { uf_is_cheap = is_cheap }) = is_cheap diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 9e3bb4a..2940814 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -121,6 +121,7 @@ mkCoreUnfolding top_lvl expr arity guidance uf_arity = arity, uf_is_top = top_lvl, uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, uf_is_cheap = exprIsCheap expr, uf_expandable = exprIsExpandable expr, uf_guidance = guidance } @@ -958,10 +959,10 @@ interestingArg e = go e 0 -- data constructors here | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding | n > 0 = NonTrivArg -- Saturated or unknown call - | evald_unfolding = ValueArg -- n==0; look for a value + | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding | otherwise = TrivArg -- n==0, no useful unfolding where - evald_unfolding = isEvaldUnfolding (idUnfolding v) + conlike_unfolding = isConLikeUnfolding (idUnfolding v) go (Type _) _ = TrivArg go (App fn (Type _)) n = go fn n diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 56a84a5..50a0109 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 @@ -662,6 +662,45 @@ idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args \end{code} \begin{code} +-- | 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 + || 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... + + 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 _ = 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} + +\begin{code} -- | This returns true for expressions that are certainly /already/ -- evaluated to /head/ normal form. This is used to decide whether it's ok @@ -692,34 +731,15 @@ 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, - -- so that [] and () are values, for example - || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings - || isEvaldUnfolding (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 = exprIsHNFlike isDataConWorkId isEvaldUnfolding +\end{code} -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 +\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 \end{code} These InstPat functions go here to avoid circularity between DataCon and Id diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 55e192d..9213e9c 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -398,13 +398,15 @@ instance Outputable Unfolding where ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con <+> brackets (pprWithCommas pprParendExpr ops) - ppr (CoreUnfolding { uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf, uf_is_cheap=cheap + ppr (CoreUnfolding { uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf + , uf_is_conlike=conlike, uf_is_cheap=cheap , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs) where pp_info = hsep [ ptext (sLit "TopLvl=") <> ppr top , ptext (sLit "Arity=") <> int arity , ptext (sLit "Value=") <> ppr hnf + , ptext (sLit "ConLike=") <> ppr conlike , ptext (sLit "Cheap=") <> ppr cheap , ptext (sLit "Expandable=") <> ppr exp , ppr g ] -- 1.7.10.4