X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSyn.lhs;h=1181931fa7723d4e1be533a6709a23dfa0313ffd;hb=5e218036aabd1666ff2b509436e4e88491596c37;hp=e09e4f29d31429ca3ad442f4a975dd19dd7b81c5;hpb=a6a4c8a8cc89b3ea664367163886fa712ff80a8f;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index e09e4f2..1181931 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -34,6 +34,7 @@ module CoreSyn ( collectArgs, coreExprCc, flattenBinds, isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, + notSccNote, -- * Unfolding data types Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), @@ -48,8 +49,9 @@ module CoreSyn ( maybeUnfoldingTemplate, otherCons, unfoldingArity, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, - isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, - isStableUnfolding, canUnfold, neverUnfoldGuidance, isInlineRuleSource, + isStableUnfolding, isStableUnfolding_maybe, + isClosedUnfolding, hasSomeUnfolding, + canUnfold, neverUnfoldGuidance, isStableSource, -- * Strictness seqExpr, seqExprs, seqUnfolding, @@ -57,6 +59,9 @@ module CoreSyn ( -- * Annotated expression data types AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, + -- ** Operations on annotated expressions + collectAnnArgs, + -- ** Operations on annotations deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs, @@ -317,7 +322,7 @@ data CoreRule = Rule { ru_name :: RuleName, -- ^ Name of the rule, for communication with the user ru_act :: Activation, -- ^ When the rule is active - + -- Rough-matching stuff -- see comments with InstEnv.Instance( is_cls, is_rough ) ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule @@ -334,6 +339,10 @@ data CoreRule -- See Note [OccInfo in unfoldings and rules] -- Locality + ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated + -- @False@ <=> generated at the users behest + -- Main effect: reporting of orphan-hood + ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is -- defined in the same module as the rule -- and is not an implicit 'Id' (like a record selector, @@ -433,17 +442,20 @@ data Unfolding -- They are usually variables, but can be trivial expressions -- instead (e.g. a type application). - | CoreUnfolding { -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma - -- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.) + | CoreUnfolding { -- An unfolding for an Id with no pragma, + -- or perhaps a NOINLINE pragma + -- (For NOINLINE, the phase, if any, is in the + -- InlinePragInfo for this Id.) uf_tmpl :: CoreExpr, -- Template; occurrence info is correct uf_src :: UnfoldingSource, -- Where the unfolding came from uf_is_top :: Bool, -- True <=> top level binding uf_arity :: Arity, -- Number of value arguments expected - 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 + uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard + -- a `seq` on this variable + uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function -- Cached version of exprIsConLike - uf_is_cheap :: Bool, -- True <=> doesn't waste (much) work to expand inside an inlining + 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 -- Cached version of exprIsExpandable @@ -467,13 +479,31 @@ data Unfolding ------------------------------------------------ data UnfoldingSource - = InlineCompulsory -- Something that *has* no binding, so you *must* inline it + = InlineRhs -- The current rhs of the function + -- Replace uf_tmpl each time around + + | InlineStable -- From an INLINE or INLINABLE pragma + -- INLINE if guidance is UnfWhen + -- INLINABLE if guidance is UnfIfGoodArgs + -- (well, technically an INLINABLE might be made + -- UnfWhen if it was small enough, and then + -- it will behave like INLINE outside the current + -- module, but that is the way automatic unfoldings + -- work so it is consistent with the intended + -- meaning of INLINABLE). + -- + -- uf_tmpl may change, but only as a result of + -- gentle simplification, it doesn't get updated + -- to the current RHS during compilation as with + -- InlineRhs. + -- + -- See Note [InlineRules] + + | InlineCompulsory -- Something that *has* no binding, so you *must* inline it -- Only a few primop-like things have this property -- (see MkId.lhs, calls to mkCompulsoryUnfolding). -- Inline absolutely always, however boring the context. - | InlineRule -- From an {-# INLINE #-} pragma; See Note [InlineRules] - | InlineWrapper Id -- This unfolding is a the wrapper in a -- worker/wrapper split from the strictness analyser -- The Id is the worker-id @@ -481,10 +511,6 @@ data UnfoldingSource -- which don't need to contain the RHS; -- it can be derived from the strictness info - | InlineRhs -- The current rhs of the function - - -- For InlineRhs, the uf_tmpl is replaced each time around - -- For all the others we leave uf_tmpl alone -- | 'UnfoldingGuidance' says when unfolding should take place @@ -579,11 +605,12 @@ seqGuidance _ = () \end{code} \begin{code} -isInlineRuleSource :: UnfoldingSource -> Bool -isInlineRuleSource InlineCompulsory = True -isInlineRuleSource InlineRule = True -isInlineRuleSource (InlineWrapper {}) = True -isInlineRuleSource InlineRhs = False +isStableSource :: UnfoldingSource -> Bool +-- Keep the unfolding template +isStableSource InlineCompulsory = True +isStableSource InlineStable = True +isStableSource (InlineWrapper {}) = True +isStableSource InlineRhs = False -- | Retrieves the template of an unfolding: panics if none is known unfoldingTemplate :: Unfolding -> CoreExpr @@ -642,19 +669,15 @@ expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs expandUnfolding_maybe _ = Nothing -isInlineRule :: Unfolding -> Bool -isInlineRule (CoreUnfolding { uf_src = src }) = isInlineRuleSource src -isInlineRule _ = False - -isInlineRule_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool) -isInlineRule_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) - | isInlineRuleSource src +isStableUnfolding_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool) +isStableUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide }) + | isStableSource src = Just (src, unsat_ok) where unsat_ok = case guide of UnfWhen unsat_ok _ -> unsat_ok _ -> needSaturated -isInlineRule_maybe _ = Nothing +isStableUnfolding_maybe _ = Nothing isCompulsoryUnfolding :: Unfolding -> Bool isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True @@ -663,7 +686,7 @@ isCompulsoryUnfolding _ = False isStableUnfolding :: Unfolding -> Bool -- True of unfoldings that should not be overwritten -- by a CoreUnfolding for the RHS of a let-binding -isStableUnfolding (CoreUnfolding { uf_src = src }) = isInlineRuleSource src +isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src isStableUnfolding (DFunUnfolding {}) = True isStableUnfolding _ = False @@ -1044,6 +1067,10 @@ valBndrCount = count isId -- | The number of argument expressions that are values rather than types at their top level valArgCount :: [Arg b] -> Int valArgCount = count isValArg + +notSccNote :: Note -> Bool +notSccNote (SCC {}) = False +notSccNote _ = True \end{code} @@ -1131,6 +1158,17 @@ data AnnBind bndr annot \end{code} \begin{code} +-- | Takes a nested application expression and returns the the function +-- being applied and the arguments to which it is applied +collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) +collectAnnArgs expr + = go expr [] + where + go (_, AnnApp f a) as = go f (a:as) + go e as = (e, as) +\end{code} + +\begin{code} deAnnotate :: AnnExpr bndr annot -> Expr bndr deAnnotate (_, e) = deAnnotate' e