X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSyn.lhs;h=2ddc7a51de992b116fd0a7542cbad74f8cb27e8f;hb=356e6869dec4b623a3aba239e72c682667a2b85e;hp=01e2be77c6517e37340631d8091d6ca7ccdbc14c;hpb=72462499b891d5779c19f3bda03f96e24f9554ae;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 01e2be7..2ddc7a5 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -4,6 +4,7 @@ % \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection module CoreSyn ( @@ -35,19 +36,20 @@ module CoreSyn ( isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, -- * Unfolding data types - Unfolding(..), UnfoldingGuidance(..), InlineRuleInfo(..), + Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), -- Abstract everywhere but in CoreUnfold.lhs -- ** Constructing 'Unfolding's noUnfolding, evaldUnfolding, mkOtherCon, + unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, -- ** Predicates and deconstruction on 'Unfolding' - unfoldingTemplate, setUnfoldingTemplate, + unfoldingTemplate, setUnfoldingTemplate, expandUnfolding_maybe, maybeUnfoldingTemplate, otherCons, unfoldingArity, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, - isExpandableUnfolding, + isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, - isStableUnfolding, canUnfold, neverUnfoldGuidance, + isStableUnfolding, canUnfold, neverUnfoldGuidance, isInlineRuleSource, -- * Strictness seqExpr, seqExprs, seqUnfolding, @@ -60,7 +62,7 @@ module CoreSyn ( -- * Core rule data types CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only - RuleName, + RuleName, IdUnfoldingFun, -- ** Operations on 'CoreRule's seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe, @@ -82,6 +84,7 @@ import FastString import Outputable import Util +import Data.Data import Data.Word infixl 4 `mkApps`, `mkTyApps`, `mkVarApps` @@ -134,11 +137,15 @@ infixl 8 `App` -- App brackets to the left -- The type parameter @b@ is for the type of binders in the expression tree. data Expr b = Var Id -- ^ Variables + | Lit Literal -- ^ Primitive literals + | App (Expr b) (Arg b) -- ^ Applications: note that the argument may be a 'Type'. -- -- See "CoreSyn#let_app_invariant" for another invariant + | Lam b (Expr b) -- ^ Lambda abstraction + | Let (Bind b) (Expr b) -- ^ Recursive and non recursive @let@s. Operationally -- this corresponds to allocating a thunk for the things -- bound and then executing the sub-expression. @@ -151,14 +158,16 @@ data Expr b -- the meaning of /lifted/ vs. /unlifted/). -- -- #let_app_invariant# - -- The right hand side of of a non-recursive 'Let' _and_ the argument of an 'App', + -- The right hand side of of a non-recursive 'Let' + -- _and_ the argument of an 'App', -- /may/ be of unlifted type, but only if the expression - -- is ok-for-speculation. This means that the let can be floated around - -- without difficulty. For example, this is OK: + -- is ok-for-speculation. This means that the let can be floated + -- around without difficulty. For example, this is OK: -- -- > y::Int# = x +# 1# -- - -- But this is not, as it may affect termination if the expression is floated out: + -- But this is not, as it may affect termination if the + -- expression is floated out: -- -- > y::Int# = fac 4# -- @@ -178,6 +187,7 @@ data Expr b -- At the moment, the rest of the compiler only deals with type-let -- in a Let expression, rather than at top level. We may want to revist -- this choice. + | Case (Expr b) b Type [Alt b] -- ^ Case split. Operationally this corresponds to evaluating -- the scrutinee (expression examined) to weak head normal form -- and then examining at most one level of resulting constructor (i.e. you @@ -187,15 +197,17 @@ data Expr b -- and the 'Type' must be that of all the case alternatives -- -- #case_invariants# - -- This is one of the more complicated elements of the Core language, and comes - -- with a number of restrictions: + -- This is one of the more complicated elements of the Core language, + -- and comes with a number of restrictions: -- - -- The 'DEFAULT' case alternative must be first in the list, if it occurs at all. + -- The 'DEFAULT' case alternative must be first in the list, + -- if it occurs at all. -- -- The remaining cases are in order of increasing -- tag (for 'DataAlts') or -- lit (for 'LitAlts'). - -- This makes finding the relevant constructor easy, and makes comparison easier too. + -- This makes finding the relevant constructor easy, + -- and makes comparison easier too. -- -- The list of alternatives must be exhaustive. An /exhaustive/ case -- does not necessarily mention all constructors: @@ -209,14 +221,19 @@ data Expr b -- Blue -> ... ) ... -- @ -- - -- The inner case does not need a @Red@ alternative, because @x@ can't be @Red@ at - -- that program point. - | Cast (Expr b) Coercion -- ^ Cast an expression to a particular type. This is used to implement @newtype@s - -- (a @newtype@ constructor or destructor just becomes a 'Cast' in Core) and GADTs. + -- The inner case does not need a @Red@ alternative, because @x@ + -- can't be @Red@ at that program point. + + | Cast (Expr b) Coercion -- ^ Cast an expression to a particular type. + -- This is used to implement @newtype@s (a @newtype@ constructor or + -- destructor just becomes a 'Cast' in Core) and GADTs. + | Note Note (Expr b) -- ^ Notes. These allow general information to be -- added to expressions in the syntax tree + | Type Type -- ^ A type: this should only show up at the top -- level of an Arg + deriving (Data, Typeable) -- | Type synonym for expressions that occur in function argument positions. -- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not @@ -232,11 +249,12 @@ data AltCon = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@ | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@ | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@ - deriving (Eq, Ord) + deriving (Eq, Ord, Data, Typeable) -- | Binding, used for top level bindings in a module and local bindings in a @let@. data Bind b = NonRec b (Expr b) | Rec [(b, (Expr b))] + deriving (Data, Typeable) \end{code} -------------------------- CoreSyn INVARIANTS --------------------------- @@ -276,6 +294,7 @@ See #type_let# data Note = SCC CostCentre -- ^ A cost centre annotation for profiling | CoreNote String -- ^ A generic core annotation, propagated but not used by GHC + deriving (Data, Typeable) \end{code} @@ -333,13 +352,18 @@ data CoreRule ru_fn :: Name, -- ^ As above ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, -- if it fires, including type arguments - ru_try :: [CoreExpr] -> Maybe CoreExpr + ru_try :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- ^ This function does the rewrite. It given too many -- arguments, it simply discards them; the returned 'CoreExpr' -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args } -- See Note [Extra args in rule matching] in Rules.lhs +type IdUnfoldingFun = Id -> Unfolding +-- A function that embodies how to unfold an Id if you need +-- to do that in the Rule. The reason we need to pass this info in +-- is that whether an Id is unfoldable depends on the simplifier phase + isBuiltinRule :: CoreRule -> Bool isBuiltinRule (BuiltinRule {}) = True isBuiltinRule _ = False @@ -408,11 +432,14 @@ data Unfolding | 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_arity :: Arity, -- Number of value arguments expected + 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 + -- 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 @@ -436,24 +463,39 @@ 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 + -- 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 + -- Used to abbreviate the uf_tmpl in interface files + -- 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 data UnfoldingGuidance - = UnfoldAlways -- There is /no original definition/, so you'd better unfold. - -- The unfolding is guaranteed to have no free variables - -- so no need to think about it during dependency analysis - - | InlineRule { -- See Note [InlineRules] - -- Be very keen to inline this - -- The uf_tmpl is the *original* RHS; do *not* replace it on - -- each simlifier run. Hence, the *actual* RHS of the function - -- may be different by now, because it may have been optimised. - ug_ir_info :: InlineRuleInfo, -- Supplementary info about the InlineRule - ug_small :: Bool -- True <=> the RHS is so small (eg no bigger than a call) - -- that you should always inline a saturated call, - } -- regardless of how boring the context is - -- See Note [INLINE for small functions] in CoreUnfold] - - | UnfoldIfGoodArgs { -- Arose from a normal Id; the info here is the + = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl + -- Used (a) for small *and* cheap unfoldings + -- (b) for INLINE functions + -- See Note [INLINE for small functions] in CoreUnfold + ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated + ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring + -- So True,True means "always" + } + + | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the -- result of a simple analysis of the RHS ug_args :: [Int], -- Discount if the argument is evaluated. @@ -466,20 +508,16 @@ data UnfoldingGuidance } -- a context (case (thing args) of ...), -- (where there are the right number of arguments.) - | UnfoldNever - -data InlineRuleInfo - = InlSat -- A user-specifed or compiler injected INLINE pragma - -- ONLY inline when it's applied to 'arity' arguments + | UnfNever -- The RHS is big, so don't inline it - | InlUnSat -- The compiler decided to "capture" the RHS into an - -- InlineRule, but do not require that it appears saturated +-- Constants for the UnfWhen constructor +needSaturated, unSaturatedOk :: Bool +needSaturated = False +unSaturatedOk = True - | InlWrapper Id -- This unfolding is a the wrapper in a - -- worker/wrapper split from the strictness analyser - -- Used to abbreviate the uf_tmpl in interface files - -- which don't need to contain the RHS; - -- it can be derived from the strictness info +boringCxtNotOk, boringCxtOk :: Bool +boringCxtOk = True +boringCxtNotOk = False ------------------------------------------------ noUnfolding :: Unfolding @@ -496,17 +534,24 @@ 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 _ = () seqGuidance :: UnfoldingGuidance -> () -seqGuidance (UnfoldIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () -seqGuidance _ = () +seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () +seqGuidance _ = () \end{code} \begin{code} +isInlineRuleSource :: UnfoldingSource -> Bool +isInlineRuleSource InlineCompulsory = True +isInlineRuleSource InlineRule = True +isInlineRuleSource (InlineWrapper {}) = True +isInlineRuleSource InlineRhs = False + -- | Retrieves the template of an unfolding: panics if none is known unfoldingTemplate :: Unfolding -> CoreExpr unfoldingTemplate = uf_tmpl @@ -541,6 +586,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 @@ -550,21 +602,37 @@ isExpandableUnfolding :: Unfolding -> Bool isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable isExpandableUnfolding _ = False -isInlineRule :: Unfolding -> Bool -isInlineRule (CoreUnfolding { uf_guidance = InlineRule {}}) = True -isInlineRule _ = False +expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr +-- Expand an expandable unfolding; this is used in rule matching +-- See Note [Expanding variables] in Rules.lhs +-- The key point here is that CONLIKE things can be expanded +expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs +expandUnfolding_maybe _ = Nothing -isInlineRule_maybe :: Unfolding -> Maybe InlineRuleInfo -isInlineRule_maybe (CoreUnfolding { - uf_guidance = InlineRule { ug_ir_info = inl } }) = Just inl -isInlineRule_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 + +isCompulsoryUnfolding :: Unfolding -> Bool +isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True +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_guidance = InlineRule {} }) = True -isStableUnfolding (DFunUnfolding {}) = True -isStableUnfolding _ = False +isStableUnfolding (CoreUnfolding { uf_src = src }) = isInlineRuleSource src +isStableUnfolding (DFunUnfolding {}) = True +isStableUnfolding _ = False unfoldingArity :: Unfolding -> Arity unfoldingArity (CoreUnfolding { uf_arity = arity }) = arity @@ -572,6 +640,7 @@ unfoldingArity _ = panic "unfoldingArity" isClosedUnfolding :: Unfolding -> Bool -- No free variables isClosedUnfolding (CoreUnfolding {}) = False +isClosedUnfolding (DFunUnfolding {}) = False isClosedUnfolding _ = True -- | Only returns False if there is no unfolding information available at all @@ -580,15 +649,15 @@ hasSomeUnfolding NoUnfolding = False hasSomeUnfolding _ = True neverUnfoldGuidance :: UnfoldingGuidance -> Bool -neverUnfoldGuidance UnfoldNever = True -neverUnfoldGuidance _ = False +neverUnfoldGuidance UnfNever = True +neverUnfoldGuidance _ = False canUnfold :: Unfolding -> Bool canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) canUnfold _ = False \end{code} -Note [InlineRule] +Note [InlineRules] ~~~~~~~~~~~~~~~~~ When you say {-# INLINE f #-} @@ -596,11 +665,13 @@ When you say you intend that calls (f e) are replaced by [e/x] So we should capture (\x.) in the Unfolding of 'f', and never meddle with it. Meanwhile, we can optimise to our heart's content, -leaving the original unfolding intact in Unfolding of 'f'. +leaving the original unfolding intact in Unfolding of 'f'. For example + all xs = foldr (&&) True xs + any p = all . map p {-# INLINE any #-} +We optimise any's RHS fully, but leave the InlineRule saying "all . map p", +which deforests well at the call site. -So the representation of an Unfolding has changed quite a bit -(see CoreSyn). An INLINE pragma gives rise to an InlineRule -unfolding. +So INLINE pragma gives rise to an InlineRule, which captures the original RHS. Moreover, it's only used when 'f' is applied to the specified number of arguments; that is, the number of argument on