X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FBasicTypes.lhs;h=33c65980ec657643cc52e0689a7311df82177aed;hb=28e44e226b7b93f823857dc6514f296a3c5ee91d;hp=9b21399c48e31f5295dddbca96efcd334d92c505;hpb=72462499b891d5779c19f3bda03f96e24f9554ae;p=ghc-hetmet.git diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 9b21399..33c6598 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -14,6 +14,8 @@ types that \end{itemize} \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} + module BasicTypes( Version, bumpVersion, initialVersion, @@ -42,8 +44,9 @@ module BasicTypes( TupCon(..), tupleParens, - OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, + OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc, + nonRuleLoopBreaker, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, @@ -56,8 +59,8 @@ module BasicTypes( CompilerPhase, Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive, RuleMatchInfo(..), isConLike, isFunLike, - InlinePragma(..), defaultInlinePragma, neverInlinePragma, dfunInlinePragma, - isDefaultInlinePragma, isInlinePragma, + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, isInlinePragma, inlinePragmaSat, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, @@ -66,6 +69,8 @@ module BasicTypes( import FastString import Outputable + +import Data.Data hiding (Fixity) \end{code} %************************************************************************ @@ -86,7 +91,7 @@ type Arity = Int \begin{code} data FunctionOrData = IsFunction | IsData - deriving (Eq, Ord) + deriving (Eq, Ord, Data, Typeable) instance Outputable FunctionOrData where ppr IsFunction = text "(function)" @@ -121,7 +126,7 @@ initialVersion = 1 -- reason/explanation from a WARNING or DEPRECATED pragma data WarningTxt = WarningTxt [FastString] | DeprecatedTxt [FastString] - deriving Eq + deriving (Eq, Data, Typeable) instance Outputable WarningTxt where ppr (WarningTxt ws) = doubleQuotes (vcat (map ftext ws)) @@ -140,8 +145,9 @@ early in the hierarchy), but also in HsSyn. \begin{code} newtype IPName name = IPName name -- ?x - deriving( Eq, Ord ) -- Ord is used in the IP name cache finite map - -- (used in HscTypes.OrigIParamCache) + deriving( Eq, Ord, Data, Typeable ) + -- Ord is used in the IP name cache finite map + -- (used in HscTypes.OrigIParamCache) ipNameName :: IPName name -> name ipNameName (IPName n) = n @@ -172,6 +178,7 @@ type RuleName = FastString \begin{code} ------------------------ data Fixity = Fixity Int FixityDirection + deriving (Data, Typeable) instance Outputable Fixity where ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] @@ -181,7 +188,7 @@ instance Eq Fixity where -- Used to determine if two fixities conflict ------------------------ data FixityDirection = InfixL | InfixR | InfixN - deriving(Eq) + deriving (Eq, Data, Typeable) instance Outputable FixityDirection where ppr InfixL = ptext (sLit "infixl") @@ -262,7 +269,7 @@ instance Outputable TopLevelFlag where data Boxity = Boxed | Unboxed - deriving( Eq ) + deriving( Eq, Data, Typeable ) isBoxed :: Boxity -> Bool isBoxed Boxed = True @@ -279,7 +286,7 @@ isBoxed Unboxed = False \begin{code} data RecFlag = Recursive | NonRecursive - deriving( Eq ) + deriving( Eq, Data, Typeable ) isRec :: RecFlag -> Bool isRec Recursive = True @@ -476,17 +483,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} @@ -583,19 +593,21 @@ data Activation = NeverActive | AlwaysActive | ActiveBefore CompilerPhase -- Active only *before* this phase | ActiveAfter CompilerPhase -- Active in this phase and later - deriving( Eq ) -- Eq used in comparing rules in HsDecls + deriving( Eq, Data, Typeable ) -- Eq used in comparing rules in HsDecls data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] | FunLike - deriving( Eq ) + deriving( Eq, Data, Typeable ) 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 ) + } deriving( Eq, Data, Typeable ) \end{code} Note [InlinePragma] @@ -611,6 +623,8 @@ If you write nothing at all, you get defaultInlinePragma: 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. @@ -656,14 +670,22 @@ 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 } - +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 } + +-- A DFun has an always-active inline activation so that +-- exprIsConApp_maybe can "see" its unfolding +-- (However, its actual Unfolding is a DFunUnfolding, which is +-- never inlined other than via exprIsConApp_maybe.) +dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive + , inl_rule = ConLike } isDefaultInlinePragma :: InlinePragma -> Bool isDefaultInlinePragma (InlinePragma { inl_act = activation @@ -674,6 +696,9 @@ isDefaultInlinePragma (InlinePragma { inl_act = activation isInlinePragma :: InlinePragma -> Bool isInlinePragma prag = inl_inline prag +inlinePragmaSat :: InlinePragma -> Maybe Arity +inlinePragmaSat = inl_sat + inlinePragmaActivation :: InlinePragma -> Activation inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation @@ -687,8 +712,8 @@ setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } instance Outputable Activation where - ppr AlwaysActive = ptext (sLit "ALWAYS") - ppr NeverActive = ptext (sLit "NEVER") + ppr AlwaysActive = brackets (ptext (sLit "ALWAYS")) + ppr NeverActive = brackets (ptext (sLit "NEVER")) ppr (ActiveBefore n) = brackets (char '~' <> int n) ppr (ActiveAfter n) = brackets (int n) @@ -697,17 +722,20 @@ instance Outputable RuleMatchInfo where 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 + ppr (InlinePragma { inl_inline = inline, inl_act = activation + , inl_rule = info, inl_sat = mb_arity }) + = pp_inl_act (inline, activation) <+> pp_sat <+> pp_info where - pp_inline | inline = ptext (sLit "INLINE") - | otherwise = ptext (sLit "NOINLINE") + pp_inl_act (False, AlwaysActive) = empty -- defaultInlinePragma + pp_inl_act (False, NeverActive) = ptext (sLit "NOINLINE") + pp_inl_act (False, act) = ptext (sLit "NOINLINE") <> ppr act + pp_inl_act (True, AlwaysActive) = ptext (sLit "INLINE") + pp_inl_act (True, act) = ptext (sLit "INLINE") <> ppr act + + pp_sat | Just ar <- mb_arity = parens (ptext (sLit "sat-args=") <> 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