X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FBasicTypes.lhs;h=b151f5b3cb85cf8f3d4cbbdfeac3b40481447bef;hp=70a9312a364c79e98c58c917a2db3424235cad75;hb=77166b1729061531eeb77c33f4d3b2581f7d4c41;hpb=0764ab4ce5810b649c07ec1bb4aabf7f44b7ed4e diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 70a9312..b151f5b 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -18,6 +18,8 @@ module BasicTypes( Version, bumpVersion, initialVersion, Arity, + + FunctionOrData(..), WarningTxt(..), @@ -40,8 +42,9 @@ module BasicTypes( TupCon(..), tupleParens, - OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, + OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc, + nonRuleLoopBreaker, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, @@ -52,8 +55,12 @@ module BasicTypes( StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, CompilerPhase, - Activation(..), isActive, isNeverActive, isAlwaysActive, - InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec, + Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive, + RuleMatchInfo(..), isConLike, isFunLike, + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, isInlinePragma, inlinePragmaSat, + inlinePragmaActivation, inlinePragmaRuleMatchInfo, + setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, SuccessFlag(..), succeeded, failed, successIf ) where @@ -72,6 +79,21 @@ import Outputable type Arity = Int \end{code} +%************************************************************************ +%* * +\subsection[FunctionOrData]{FunctionOrData} +%* * +%************************************************************************ + +\begin{code} +data FunctionOrData = IsFunction | IsData + deriving (Eq, Ord) + +instance Outputable FunctionOrData where + ppr IsFunction = text "(function)" + ppr IsData = text "(data)" +\end{code} + %************************************************************************ %* * @@ -98,13 +120,14 @@ initialVersion = 1 \begin{code} -- reason/explanation from a WARNING or DEPRECATED pragma -data WarningTxt = WarningTxt FastString - | DeprecatedTxt FastString +data WarningTxt = WarningTxt [FastString] + | DeprecatedTxt [FastString] deriving Eq instance Outputable WarningTxt where - ppr (WarningTxt w) = doubleQuotes (ftext w) - ppr (DeprecatedTxt d) = text "Deprecated:" <+> doubleQuotes (ftext d) + ppr (WarningTxt ws) = doubleQuotes (vcat (map ftext ws)) + ppr (DeprecatedTxt ds) = text "Deprecated:" <+> + doubleQuotes (vcat (map ftext ds)) \end{code} %************************************************************************ @@ -454,17 +477,20 @@ isNonRuleLoopBreaker :: OccInfo -> Bool isNonRuleLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle isNonRuleLoopBreaker _ = False +nonRuleLoopBreaker :: OccInfo +nonRuleLoopBreaker = IAmALoopBreaker False + isDeadOcc :: OccInfo -> Bool isDeadOcc IAmDead = True isDeadOcc _ = False isOneOcc :: OccInfo -> Bool -isOneOcc (OneOcc _ _ _) = True -isOneOcc _ = False +isOneOcc (OneOcc {}) = True +isOneOcc _ = False -isFragileOcc :: OccInfo -> Bool -isFragileOcc (OneOcc _ _ _) = True -isFragileOcc _ = False +zapFragileOcc :: OccInfo -> OccInfo +zapFragileOcc (OneOcc {}) = NoOccInfo +zapFragileOcc occ = occ \end{code} \begin{code} @@ -563,35 +589,142 @@ data Activation = NeverActive | ActiveAfter CompilerPhase -- Active in this phase and later deriving( Eq ) -- Eq used in comparing rules in HsDecls -data InlineSpec - = Inline - Activation -- Says during which phases inlining is allowed - Bool -- True <=> INLINE - -- False <=> NOINLINE - deriving( Eq ) +data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] + | FunLike + deriving( Eq ) + +data InlinePragma -- Note [InlinePragma] + = InlinePragma + { inl_inline :: Bool -- True <=> INLINE, + -- False <=> no pragma at all, or NOINLINE + , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n + -- explicit (non-type, non-dictionary) args + , inl_act :: Activation -- Says during which phases inlining is allowed + , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? + } deriving( Eq ) +\end{code} + +Note [InlinePragma] +~~~~~~~~~~~~~~~~~~~ +This data type mirrors what you can write in an INLINE or NOINLINE pragma in +the source program. + +If you write nothing at all, you get defaultInlinePragma: + inl_inline = False + inl_act = AlwaysActive + inl_rule = FunLike + +It's not possible to get that combination by *writing* something, so +if an Id has defaultInlinePragma it means the user didn't specify anything. + +If inl_inline = True, then the Id should have an InlineRule unfolding. + +Note [CONLIKE pragma] +~~~~~~~~~~~~~~~~~~~~~ +The ConLike constructor of a RuleMatchInfo is aimed at the following. +Consider first + {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} + g b bs = let x = b:bs in ..x...x...(r x)... +Now, the rule applies to the (r x) term, because GHC "looks through" +the definition of 'x' to see that it is (b:bs). + +Now consider + {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} + g v = let x = f v in ..x...x...(r x)... +Normally the (r x) would *not* match the rule, because GHC would be +scared about duplicating the redex (f v), so it does not "look +through" the bindings. + +However the CONLIKE modifier says to treat 'f' like a constructor in +this situation, and "look through" the unfolding for x. So (r x) +fires, yielding (f (v+1)). -defaultInlineSpec, alwaysInlineSpec, neverInlineSpec :: InlineSpec +This is all controlled with a user-visible pragma: + {-# NOINLINE CONLIKE [1] f #-} -defaultInlineSpec = Inline AlwaysActive False -- Inlining is OK, but not forced -alwaysInlineSpec = Inline AlwaysActive True -- INLINE always -neverInlineSpec = Inline NeverActive False -- NOINLINE +The main effects of CONLIKE are: + + - The occurrence analyser (OccAnal) and simplifier (Simplify) treat + CONLIKE thing like constructors, by ANF-ing them + + - New function coreUtils.exprIsExpandable is like exprIsCheap, but + additionally spots applications of CONLIKE functions + + - A CoreUnfolding has a field that caches exprIsExpandable + + - The rule matcher consults this field. See + Note [Expanding variables] in Rules.lhs. + +\begin{code} +isConLike :: RuleMatchInfo -> Bool +isConLike ConLike = True +isConLike _ = False + +isFunLike :: RuleMatchInfo -> Bool +isFunLike FunLike = True +isFunLike _ = False + +defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma + :: InlinePragma +defaultInlinePragma = InlinePragma { inl_act = AlwaysActive + , inl_rule = FunLike + , inl_inline = False + , inl_sat = Nothing } + +alwaysInlinePragma = defaultInlinePragma { inl_inline = True } +neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } +dfunInlinePragma = defaultInlinePragma { inl_rule = ConLike } + + +isDefaultInlinePragma :: InlinePragma -> Bool +isDefaultInlinePragma (InlinePragma { inl_act = activation + , inl_rule = match_info + , inl_inline = inline }) + = not inline && isAlwaysActive activation && isFunLike match_info + +isInlinePragma :: InlinePragma -> Bool +isInlinePragma prag = inl_inline prag + +inlinePragmaSat :: InlinePragma -> Maybe Arity +inlinePragmaSat = inl_sat + +inlinePragmaActivation :: InlinePragma -> Activation +inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation + +inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo +inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info + +setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma +setInlinePragmaActivation prag activation = prag { inl_act = activation } + +setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma +setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } instance Outputable Activation where - ppr NeverActive = ptext (sLit "NEVER") ppr AlwaysActive = ptext (sLit "ALWAYS") + ppr NeverActive = ptext (sLit "NEVER") ppr (ActiveBefore n) = brackets (char '~' <> int n) ppr (ActiveAfter n) = brackets (int n) - -instance Outputable InlineSpec where - ppr (Inline act is_inline) - | is_inline = ptext (sLit "INLINE") - <> case act of - AlwaysActive -> empty - _ -> ppr act - | otherwise = ptext (sLit "NOINLINE") - <> case act of - NeverActive -> empty - _ -> ppr act + +instance Outputable RuleMatchInfo where + ppr ConLike = ptext (sLit "CONLIKE") + ppr FunLike = ptext (sLit "FUNLIKE") + +instance Outputable InlinePragma where + ppr (InlinePragma { inl_inline = inline, inl_act = activation + , inl_rule = info, inl_sat = mb_arity }) + = pp_inline <> pp_sat <+> pp_info <+> pp_activation + where + pp_inline | inline = ptext (sLit "INLINE") + | otherwise = ptext (sLit "NOINLINE") + pp_sat | Just ar <- mb_arity = braces (int ar) + | otherwise = empty + pp_info | isFunLike info = empty + | otherwise = ppr info + pp_activation + | inline && isAlwaysActive activation = empty + | not inline && isNeverActive activation = empty + | otherwise = ppr activation isActive :: CompilerPhase -> Activation -> Bool isActive _ NeverActive = False @@ -599,11 +732,15 @@ isActive _ AlwaysActive = True isActive p (ActiveAfter n) = p <= n isActive p (ActiveBefore n) = p > n -isNeverActive, isAlwaysActive :: Activation -> Bool +isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool isNeverActive NeverActive = True isNeverActive _ = False isAlwaysActive AlwaysActive = True isAlwaysActive _ = False + +isEarlyActive AlwaysActive = True +isEarlyActive (ActiveBefore {}) = True +isEarlyActive _ = False \end{code}