X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSyn.lhs;h=603b745cf2547e4a8c14894f7396f5dd502c5db1;hb=841e81e28f8cc711f624fdca122219a5bbde2fae;hp=fb7865b354f56150cdf7ad0085aefd86dc2554ae;hpb=66413c79385a5b30a668e91789b8a334f6977ca9;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index fb7865b..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 ( @@ -37,9 +37,9 @@ module CoreSyn ( 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, @@ -49,7 +49,7 @@ module CoreSyn ( maybeUnfoldingTemplate, otherCons, unfoldingArity, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, - isStableUnfolding, isStableUnfolding_maybe, + isStableUnfolding, isStableCoreUnfolding_maybe, isClosedUnfolding, hasSomeUnfolding, canUnfold, neverUnfoldGuidance, isStableSource, @@ -59,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, @@ -67,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" @@ -319,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 @@ -336,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, @@ -377,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 @@ -395,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 %* * @@ -430,10 +454,7 @@ 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 @@ -471,12 +492,42 @@ data Unfolding -- uf_guidance: Tells us about the /size/ of the unfolding template ------------------------------------------------ -data UnfoldingSource +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 - -- Do not replace uf_tmpl; instead, keep it unchanged + -- 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 @@ -649,15 +700,10 @@ expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs expandUnfolding_maybe _ = Nothing -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 -isStableUnfolding_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 @@ -1138,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