X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSyn.lhs;h=603b745cf2547e4a8c14894f7396f5dd502c5db1;hp=2ad111f261bab6dc870821e4ad55ecc6d90ba3cc;hb=b6264a6b8a8e22e24464da39ca0a3a0176d91f4e;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 2ad111f..603b745 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -4,7 +4,7 @@ % \begin{code} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection module CoreSyn ( @@ -34,11 +34,12 @@ module CoreSyn ( collectArgs, coreExprCc, flattenBinds, isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, + notSccNote, -- * Unfolding data types - Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), - -- Abstract everywhere but in CoreUnfold.lhs - + Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), + DFunArg(..), dfunArgExprs, + -- ** Constructing 'Unfolding's noUnfolding, evaldUnfolding, mkOtherCon, unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, @@ -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, isStableCoreUnfolding_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, @@ -65,9 +70,12 @@ module CoreSyn ( RuleName, IdUnfoldingFun, -- ** Operations on 'CoreRule's - seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe, + seqRules, ruleArity, ruleName, ruleIdName, ruleActivation, setRuleIdName, - isBuiltinRule, isLocalRule + isBuiltinRule, isLocalRule, + + -- * Core vectorisation declarations data type + CoreVect(..) ) where #include "HsVersions.h" @@ -317,7 +325,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 +342,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, @@ -375,9 +387,9 @@ ruleArity (Rule {ru_args = args}) = length args ruleName :: CoreRule -> RuleName ruleName = ru_name -ruleActivation_maybe :: CoreRule -> Maybe Activation -ruleActivation_maybe (BuiltinRule { }) = Nothing -ruleActivation_maybe (Rule { ru_act = act }) = Just act +ruleActivation :: CoreRule -> Activation +ruleActivation (BuiltinRule { }) = AlwaysActive +ruleActivation (Rule { ru_act = act }) = act -- | The 'Name' of the 'Id.Id' at the head of the rule left hand side ruleIdName :: CoreRule -> Name @@ -393,6 +405,20 @@ setRuleIdName nm ru = ru { ru_fn = nm } %************************************************************************ +%* * +\subsection{Vectorisation declarations} +%* * +%************************************************************************ + +Representation of desugared vectorisation declarations that are fed to the vectoriser (via +'ModGuts'). + +\begin{code} +data CoreVect = Vect Id (Maybe CoreExpr) +\end{code} + + +%************************************************************************ %* * Unfoldings %* * @@ -428,22 +454,22 @@ data Unfolding DataCon -- The dictionary data constructor (possibly a newtype datacon) - [CoreExpr] -- The [CoreExpr] are the superclasses and methods [op1,op2], - -- in positional order. - -- They are usually variables, but can be trivial expressions - -- instead (e.g. a type application). + [DFunArg CoreExpr] -- Specification of superclasses and methods, in positional order - | 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 @@ -466,14 +492,49 @@ data Unfolding -- uf_guidance: Tells us about the /size/ of the unfolding template ------------------------------------------------ -data UnfoldingSource - = InlineCompulsory -- Something that *has* no binding, so you *must* inline it +data DFunArg e -- Given (df a b d1 d2 d3) + = DFunPolyArg e -- Arg is (e a b d1 d2 d3) + | DFunConstArg e -- Arg is e, which is constant + | DFunLamArg Int -- Arg is one of [a,b,d1,d2,d3], zero indexed + deriving( Functor ) + + -- 'e' is often CoreExpr, which are usually variables, but can + -- be trivial expressions instead (e.g. a type application). + +dfunArgExprs :: [DFunArg e] -> [e] +dfunArgExprs [] = [] +dfunArgExprs (DFunPolyArg e : as) = e : dfunArgExprs as +dfunArgExprs (DFunConstArg e : as) = e : dfunArgExprs as +dfunArgExprs (DFunLamArg {} : as) = dfunArgExprs as + + +------------------------------------------------ +data UnfoldingSource + = 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/UnfoldNever + -- (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 +542,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 @@ -536,8 +593,11 @@ The instance translates to Now we might encounter (op (dfCList {ty} d) a1 a2) and we want the (op (dfList {ty} d)) rule to fire, because $dfCList has all its arguments, even though its (value) arity is 2. That's -why we cache the number of expected +why we record the number of expected arguments in the DFunUnfolding. +Note that although it's an Arity, it's most convenient for it to give +the *total* number of arguments, both type and value. See the use +site in exprIsConApp_maybe. \begin{code} -- Constants for the UnfWhen constructor @@ -576,11 +636,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 @@ -639,19 +700,10 @@ 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 - = Just (src, unsat_ok) - where - unsat_ok = case guide of - UnfWhen unsat_ok _ -> unsat_ok - _ -> needSaturated -isInlineRule_maybe _ = Nothing +isStableCoreUnfolding_maybe :: Unfolding -> Maybe UnfoldingSource +isStableCoreUnfolding_maybe (CoreUnfolding { uf_src = src }) + | isStableSource src = Just src +isStableCoreUnfolding_maybe _ = Nothing isCompulsoryUnfolding :: Unfolding -> Bool isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True @@ -660,7 +712,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 @@ -1041,6 +1093,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} @@ -1128,6 +1184,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