X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FBasicTypes.lhs;h=9b21399c48e31f5295dddbca96efcd334d92c505;hp=2bb2f360089bc6697b32700de783788f11d14016;hb=72462499b891d5779c19f3bda03f96e24f9554ae;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 2bb2f36..9b21399 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -14,19 +14,14 @@ types that \end{itemize} \begin{code} -{-# OPTIONS_GHC -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings --- for details - module BasicTypes( Version, bumpVersion, initialVersion, Arity, + + FunctionOrData(..), - DeprecTxt, + WarningTxt(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, @@ -37,6 +32,8 @@ module BasicTypes( RecFlag(..), isRec, isNonRec, boolToRecFlag, + RuleName, + TopLevelFlag(..), isTopLevel, isNotTopLevel, OverlapFlag(..), @@ -57,15 +54,17 @@ module BasicTypes( StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, CompilerPhase, - Activation(..), isActive, isNeverActive, isAlwaysActive, - InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec, + Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive, + RuleMatchInfo(..), isConLike, isFunLike, + InlinePragma(..), defaultInlinePragma, neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, isInlinePragma, + inlinePragmaActivation, inlinePragmaRuleMatchInfo, + setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, SuccessFlag(..), succeeded, failed, successIf ) where -#include "HsVersions.h" - -import FastString( FastString ) +import FastString import Outputable \end{code} @@ -79,6 +78,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} + %************************************************************************ %* * @@ -104,7 +118,15 @@ initialVersion = 1 \begin{code} -type DeprecTxt = FastString -- reason/explanation for deprecation +-- reason/explanation from a WARNING or DEPRECATED pragma +data WarningTxt = WarningTxt [FastString] + | DeprecatedTxt [FastString] + deriving Eq + +instance Outputable WarningTxt where + ppr (WarningTxt ws) = doubleQuotes (vcat (map ftext ws)) + ppr (DeprecatedTxt ds) = text "Deprecated:" <+> + doubleQuotes (vcat (map ftext ds)) \end{code} %************************************************************************ @@ -131,6 +153,15 @@ instance Outputable name => Outputable (IPName name) where ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters \end{code} +%************************************************************************ +%* * + Rules +%* * +%************************************************************************ + +\begin{code} +type RuleName = FastString +\end{code} %************************************************************************ %* * @@ -153,12 +184,14 @@ data FixityDirection = InfixL | InfixR | InfixN deriving(Eq) instance Outputable FixityDirection where - ppr InfixL = ptext SLIT("infixl") - ppr InfixR = ptext SLIT("infixr") - ppr InfixN = ptext SLIT("infix") + ppr InfixL = ptext (sLit "infixl") + ppr InfixR = ptext (sLit "infixr") + ppr InfixN = ptext (sLit "infix") ------------------------ -maxPrecedence = (9::Int) +maxPrecedence :: Int +maxPrecedence = 9 +defaultFixity :: Fixity defaultFixity = Fixity maxPrecedence InfixL negateFixity, funTyFixity :: Fixity @@ -214,8 +247,8 @@ isTopLevel TopLevel = True isTopLevel NotTopLevel = False instance Outputable TopLevelFlag where - ppr TopLevel = ptext SLIT("") - ppr NotTopLevel = ptext SLIT("") + ppr TopLevel = ptext (sLit "") + ppr NotTopLevel = ptext (sLit "") \end{code} @@ -261,8 +294,8 @@ boolToRecFlag True = Recursive boolToRecFlag False = NonRecursive instance Outputable RecFlag where - ppr Recursive = ptext SLIT("Recursive") - ppr NonRecursive = ptext SLIT("NonRecursive") + ppr Recursive = ptext (sLit "Recursive") + ppr NonRecursive = ptext (sLit "NonRecursive") \end{code} %************************************************************************ @@ -301,8 +334,8 @@ data OverlapFlag instance Outputable OverlapFlag where ppr NoOverlap = empty - ppr OverlapOk = ptext SLIT("[overlap ok]") - ppr Incoherent = ptext SLIT("[incoherent]") + ppr OverlapOk = ptext (sLit "[overlap ok]") + ppr Incoherent = ptext (sLit "[incoherent]") \end{code} @@ -320,7 +353,7 @@ instance Eq TupCon where tupleParens :: Boxity -> SDoc -> SDoc tupleParens Boxed p = parens p -tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)") +tupleParens Unboxed p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") \end{code} %************************************************************************ @@ -372,32 +405,45 @@ the base of the module hierarchy. So it seemed simpler to put the defn of OccInfo here, safely at the bottom \begin{code} +-- | Identifier occurrence information data OccInfo - = NoOccInfo -- Many occurrences, or unknown + = NoOccInfo -- ^ There are many occurrences, or unknown occurences - | IAmDead -- Marks unused variables. Sometimes useful for + | IAmDead -- ^ Marks unused variables. Sometimes useful for -- lambda and case-bound variables. - | OneOcc -- Occurs exactly once, not inside a rule + | OneOcc !InsideLam !OneBranch - !InterestingCxt + !InterestingCxt -- ^ Occurs exactly once, not inside a rule - | IAmALoopBreaker -- Used by the occurrence analyser to mark loop-breakers - -- in a group of recursive definitions - !RulesOnly -- True <=> This loop breaker mentions the other binders - -- in its recursive group only in its RULES, not - -- in its rhs - -- See OccurAnal Note [RulesOnly] + -- | This identifier breaks a loop of mutually recursive functions. The field + -- marks whether it is only a loop breaker due to a reference in a rule + | IAmALoopBreaker -- Note [LoopBreaker OccInfo] + !RulesOnly -- True <=> This is a weak or rules-only loop breaker + -- See OccurAnal Note [Weak loop breakers] type RulesOnly = Bool \end{code} +Note [LoopBreaker OccInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +An OccInfo of (IAmLoopBreaker False) is used by the occurrence +analyser in two ways: + (a) to mark loop-breakers in a group of recursive + definitions (hence the name) + (b) to mark binders that must not be inlined in this phase + (perhaps it has a NOINLINE pragma) +Things with (IAmLoopBreaker False) do not get an unfolding +pinned on to them, so they are completely opaque. + +See OccurAnal Note [Weak loop breakers] for (IAmLoopBreaker True). + \begin{code} isNoOcc :: OccInfo -> Bool isNoOcc NoOccInfo = True -isNoOcc other = False +isNoOcc _ = False seqOccInfo :: OccInfo -> () seqOccInfo occ = occ `seq` () @@ -411,43 +457,46 @@ type InterestingCxt = Bool -- True <=> Function: is applied type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda -- Substituting a redex for this occurrence is -- dangerous because it might duplicate work. +insideLam, notInsideLam :: InsideLam insideLam = True notInsideLam = False ----------------- type OneBranch = Bool -- True <=> Occurs in only one case branch -- so no code-duplication issue to worry about +oneBranch, notOneBranch :: OneBranch oneBranch = True notOneBranch = False isLoopBreaker :: OccInfo -> Bool isLoopBreaker (IAmALoopBreaker _) = True -isLoopBreaker other = False +isLoopBreaker _ = False isNonRuleLoopBreaker :: OccInfo -> Bool -isNonRuleLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle -isNonRuleLoopBreaker other = False +isNonRuleLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle +isNonRuleLoopBreaker _ = False isDeadOcc :: OccInfo -> Bool isDeadOcc IAmDead = True -isDeadOcc other = False +isDeadOcc _ = False +isOneOcc :: OccInfo -> Bool isOneOcc (OneOcc _ _ _) = True -isOneOcc other = False +isOneOcc _ = False isFragileOcc :: OccInfo -> Bool isFragileOcc (OneOcc _ _ _) = True -isFragileOcc other = False +isFragileOcc _ = False \end{code} \begin{code} instance Outputable OccInfo where -- only used for debugging; never parsed. KSW 1999-07 ppr NoOccInfo = empty - ppr (IAmALoopBreaker ro) = ptext SLIT("LoopBreaker") <> if ro then char '!' else empty - ppr IAmDead = ptext SLIT("Dead") + ppr (IAmALoopBreaker ro) = ptext (sLit "LoopBreaker") <> if ro then char '!' else empty + ppr IAmDead = ptext (sLit "Dead") ppr (OneOcc inside_lam one_branch int_cxt) - = ptext SLIT("Once") <> pp_lam <> pp_br <> pp_args + = ptext (sLit "Once") <> pp_lam <> pp_br <> pp_args where pp_lam | inside_lam = char 'L' | otherwise = empty @@ -476,16 +525,18 @@ data StrictnessMark -- Used in interface decls only | NotMarkedStrict deriving( Eq ) +isMarkedUnboxed :: StrictnessMark -> Bool isMarkedUnboxed MarkedUnboxed = True -isMarkedUnboxed other = False +isMarkedUnboxed _ = False +isMarkedStrict :: StrictnessMark -> Bool isMarkedStrict NotMarkedStrict = False -isMarkedStrict other = True -- All others are strict +isMarkedStrict _ = True -- All others are strict instance Outputable StrictnessMark where - ppr MarkedStrict = ptext SLIT("!") - ppr MarkedUnboxed = ptext SLIT("!!") - ppr NotMarkedStrict = ptext SLIT("_") + ppr MarkedStrict = ptext (sLit "!") + ppr MarkedUnboxed = ptext (sLit "!!") + ppr NotMarkedStrict = ptext (sLit "_") \end{code} @@ -499,8 +550,8 @@ instance Outputable StrictnessMark where data SuccessFlag = Succeeded | Failed instance Outputable SuccessFlag where - ppr Succeeded = ptext SLIT("Succeeded") - ppr Failed = ptext SLIT("Failed") + ppr Succeeded = ptext (sLit "Succeeded") + ppr Failed = ptext (sLit "Failed") successIf :: Bool -> SuccessFlag successIf True = Succeeded @@ -534,38 +585,145 @@ 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 <=> make the RHS look small, so that when inlining - -- is enabled, it will definitely actually happen - 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_act :: Activation -- Says during which phases inlining is allowed + , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? + } deriving( Eq ) +\end{code} -defaultInlineSpec = Inline AlwaysActive False -- Inlining is OK, but not forced -alwaysInlineSpec = Inline AlwaysActive True -- INLINE always -neverInlineSpec = Inline NeverActive False -- NOINLINE +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. + +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)). + +This is all controlled with a user-visible pragma: + {-# NOINLINE CONLIKE [1] f #-} + +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, neverInlinePragma, dfunInlinePragma :: InlinePragma +defaultInlinePragma + = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = False } +neverInlinePragma + = InlinePragma { inl_act = NeverActive, inl_rule = FunLike, inl_inline = False } +dfunInlinePragma + = InlinePragma { inl_act = AlwaysActive, inl_rule = ConLike, inl_inline = False } + + +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 + +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 AlwaysActive = empty -- The default + ppr AlwaysActive = ptext (sLit "ALWAYS") + ppr NeverActive = ptext (sLit "NEVER") ppr (ActiveBefore n) = brackets (char '~' <> int n) ppr (ActiveAfter n) = brackets (int n) - ppr NeverActive = ptext SLIT("NEVER") - -instance Outputable InlineSpec where - ppr (Inline act True) = ptext SLIT("INLINE") <> ppr act - ppr (Inline act False) = ptext SLIT("NOINLINE") <> 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 }) + = pp_inline <+> pp_info <+> pp_activation + where + pp_inline | inline = ptext (sLit "INLINE") + | otherwise = ptext (sLit "NOINLINE") + 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 p NeverActive = False -isActive p AlwaysActive = True +isActive _ NeverActive = False +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 act = False +isNeverActive _ = False isAlwaysActive AlwaysActive = True -isAlwaysActive other = False +isAlwaysActive _ = False + +isEarlyActive AlwaysActive = True +isEarlyActive (ActiveBefore {}) = True +isEarlyActive _ = False \end{code}