X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FBasicTypes.lhs;h=65002d57ced5bf2fb0d6ffab55b38b0eb7951c90;hp=0182139b761b26e827ddd03dc463274425bed7f0;hb=6ddfe9b18d4d280676aab2fa797ddbe6f8a09d6b;hpb=2476249a77bde34ea2052910f111a3424c366db6 diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 0182139..65002d5 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -14,12 +14,14 @@ types that \end{itemize} \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} + module BasicTypes( Version, bumpVersion, initialVersion, Arity, - FunctionOrData(..), + FunctionOrData(..), WarningTxt(..), @@ -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, @@ -51,21 +54,34 @@ module BasicTypes( EP(..), - StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, - - CompilerPhase, - Activation(..), isActive, isNeverActive, isAlwaysActive, - RuleMatchInfo(..), isConLike, isFunLike, - InlinePragma(..), defaultInlinePragma, isDefaultInlinePragma, + HsBang(..), isBanged, isMarkedUnboxed, + StrictnessMark(..), isMarkedStrict, + + DefMethSpec(..), + + CompilerPhase(..), PhaseNum, + Activation(..), isActive, isActiveIn, + isNeverActive, isAlwaysActive, isEarlyActive, + RuleMatchInfo(..), isConLike, isFunLike, + InlineSpec(..), + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, + neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, + isInlinePragma, isInlinablePragma, isAnyInlinePragma, + inlinePragmaSpec, inlinePragmaSat, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, - InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec, - SuccessFlag(..), succeeded, failed, successIf + SuccessFlag(..), succeeded, failed, successIf, + + FractionalLit(..), negateFractionalLit, integralFractionalLit ) where import FastString import Outputable + +import Data.Data hiding (Fixity) +import Data.Function (on) \end{code} %************************************************************************ @@ -86,7 +102,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 +137,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 +156,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 +189,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 +199,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 +280,7 @@ instance Outputable TopLevelFlag where data Boxity = Boxed | Unboxed - deriving( Eq ) + deriving( Eq, Data, Typeable ) isBoxed :: Boxity -> Bool isBoxed Boxed = True @@ -279,7 +297,7 @@ isBoxed Unboxed = False \begin{code} data RecFlag = Recursive | NonRecursive - deriving( Eq ) + deriving( Eq, Data, Typeable ) isRec :: RecFlag -> Bool isRec Recursive = True @@ -314,6 +332,7 @@ data OverlapFlag -- -- Example: constraint (Foo [Int]) -- instances (Foo [Int]) + -- (Foo [a]) OverlapOk -- Since the second instance has the OverlapOk flag, -- the first instance will be chosen (otherwise @@ -476,17 +495,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} @@ -511,7 +533,7 @@ instance Show OccInfo where %************************************************************************ %* * -\subsection{Strictness indication} + Strictness indication %* * %************************************************************************ @@ -519,29 +541,73 @@ The strictness annotations on types in data type declarations e.g. data T = MkT !Int !(Bool,Bool) \begin{code} -data StrictnessMark -- Used in interface decls only - = MarkedStrict - | MarkedUnboxed - | NotMarkedStrict - deriving( Eq ) +------------------------- +-- HsBang describes what the *programmer* wrote +-- This info is retained in the DataCon.dcStrictMarks field +data HsBang = HsNoBang -isMarkedUnboxed :: StrictnessMark -> Bool -isMarkedUnboxed MarkedUnboxed = True -isMarkedUnboxed _ = False + | HsStrict -isMarkedStrict :: StrictnessMark -> Bool -isMarkedStrict NotMarkedStrict = False -isMarkedStrict _ = True -- All others are strict + | HsUnpack -- {-# UNPACK #-} ! (GHC extension, meaning "unbox") + + | HsUnpackFailed -- An UNPACK pragma that we could not make + -- use of, because the type isn't unboxable; + -- equivalant to HsStrict except for checkValidDataCon + deriving (Eq, Data, Typeable) + +instance Outputable HsBang where + ppr HsNoBang = empty + ppr HsStrict = char '!' + ppr HsUnpack = ptext (sLit "{-# UNPACK #-} !") + ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !") + +isBanged :: HsBang -> Bool +isBanged HsNoBang = False +isBanged _ = True + +isMarkedUnboxed :: HsBang -> Bool +isMarkedUnboxed HsUnpack = True +isMarkedUnboxed _ = False + +------------------------- +-- StrictnessMark is internal only, used to indicate strictness +-- of the DataCon *worker* fields +data StrictnessMark = MarkedStrict | NotMarkedStrict instance Outputable StrictnessMark where ppr MarkedStrict = ptext (sLit "!") - ppr MarkedUnboxed = ptext (sLit "!!") - ppr NotMarkedStrict = ptext (sLit "_") + ppr NotMarkedStrict = empty + +isMarkedStrict :: StrictnessMark -> Bool +isMarkedStrict NotMarkedStrict = False +isMarkedStrict _ = True -- All others are strict \end{code} %************************************************************************ %* * + Default method specfication +%* * +%************************************************************************ + +The DefMethSpec enumeration just indicates what sort of default method +is used for a class. It is generated from source code, and present in +interface files; it is converted to Class.DefMeth before begin put in a +Class object. + +\begin{code} +data DefMethSpec = NoDM -- No default method + | VanillaDM -- Default method given with polymorphic code + | GenericDM -- Default method given with generic code + +instance Outputable DefMethSpec where + ppr NoDM = empty + ppr VanillaDM = ptext (sLit "{- Has default method -}") + ppr GenericDM = ptext (sLit "{- Has generic default method -}") +\end{code} + +%************************************************************************ +%* * \subsection{Success flag} %* * %************************************************************************ @@ -575,20 +641,106 @@ failed Failed = True When a rule or inlining is active \begin{code} -type CompilerPhase = Int -- Compilation phase - -- Phases decrease towards zero - -- Zero is the last phase +type PhaseNum = Int -- Compilation phase + -- Phases decrease towards zero + -- Zero is the last phase + +data CompilerPhase + = Phase PhaseNum + | InitialPhase -- The first phase -- number = infinity! + +instance Outputable CompilerPhase where + ppr (Phase n) = int n + ppr InitialPhase = ptext (sLit "InitialPhase") 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 + | ActiveBefore PhaseNum -- Active only *before* this phase + | ActiveAfter PhaseNum -- Active in this phase and later + deriving( Eq, Data, Typeable ) -- Eq used in comparing rules in HsDecls -data RuleMatchInfo = ConLike +data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] | FunLike - deriving( Eq ) + deriving( Eq, Data, Typeable, Show ) + -- Show needed for Lexer.x + +data InlinePragma -- Note [InlinePragma] + = InlinePragma + { inl_inline :: InlineSpec + , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n + -- explicit (non-type, non-dictionary) args + -- That is, inl_sat describes the number of *source-code* + -- arguments the thing must be applied to. We add on the + -- number of implicit, dictionary arguments when making + -- the InlineRule, and don't look at inl_sat further + + , inl_act :: Activation -- Says during which phases inlining is allowed + + , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? + } deriving( Eq, Data, Typeable ) + +data InlineSpec -- What the user's INLINE pragama looked like + = Inline + | Inlinable + | NoInline + | EmptyInlineSpec + deriving( Eq, Data, Typeable, Show ) + -- Show needed for Lexer.x +\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)). + +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 @@ -597,55 +749,71 @@ isFunLike :: RuleMatchInfo -> Bool isFunLike FunLike = True isFunLike _ = False -data InlinePragma - = InlinePragma - Activation -- Says during which phases inlining is allowed - RuleMatchInfo -- Should the function be treated like a constructor? - deriving( Eq ) +isEmptyInlineSpec :: InlineSpec -> Bool +isEmptyInlineSpec EmptyInlineSpec = True +isEmptyInlineSpec _ = False -defaultInlinePragma :: InlinePragma -defaultInlinePragma = InlinePragma AlwaysActive FunLike +defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma + :: InlinePragma +defaultInlinePragma = InlinePragma { inl_act = AlwaysActive + , inl_rule = FunLike + , inl_inline = EmptyInlineSpec + , inl_sat = Nothing } + +alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } +neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } + +inlinePragmaSpec :: InlinePragma -> InlineSpec +inlinePragmaSpec = inl_inline + +-- 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 activation match_info) - = isAlwaysActive activation && isFunLike match_info +isDefaultInlinePragma (InlinePragma { inl_act = activation + , inl_rule = match_info + , inl_inline = inline }) + = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info + +isInlinePragma :: InlinePragma -> Bool +isInlinePragma prag = case inl_inline prag of + Inline -> True + _ -> False + +isInlinablePragma :: InlinePragma -> Bool +isInlinablePragma prag = case inl_inline prag of + Inlinable -> True + _ -> False + +isAnyInlinePragma :: InlinePragma -> Bool +-- INLINE or INLINABLE +isAnyInlinePragma prag = case inl_inline prag of + Inline -> True + Inlinable -> True + _ -> False + +inlinePragmaSat :: InlinePragma -> Maybe Arity +inlinePragmaSat = inl_sat inlinePragmaActivation :: InlinePragma -> Activation -inlinePragmaActivation (InlinePragma activation _) = activation +inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -inlinePragmaRuleMatchInfo (InlinePragma _ info) = info +inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma -setInlinePragmaActivation (InlinePragma _ info) activation - = InlinePragma activation info +setInlinePragmaActivation prag activation = prag { inl_act = activation } setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma -setInlinePragmaRuleMatchInfo (InlinePragma activation _) info - = InlinePragma activation info - -data InlineSpec - = Inline - InlinePragma - Bool -- True <=> INLINE - -- False <=> NOINLINE - deriving( Eq ) - -defaultInlineSpec :: InlineSpec -alwaysInlineSpec, neverInlineSpec :: RuleMatchInfo -> InlineSpec - -defaultInlineSpec = Inline defaultInlinePragma False - -- Inlining is OK, but not forced -alwaysInlineSpec match_info - = Inline (InlinePragma AlwaysActive match_info) True - -- INLINE always -neverInlineSpec match_info - = Inline (InlinePragma NeverActive match_info) False - -- NOINLINE +setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } instance Outputable Activation where - ppr NeverActive = ptext (sLit "NEVER") - ppr AlwaysActive = ptext (sLit "ALWAYS") + 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) @@ -653,38 +821,79 @@ instance Outputable RuleMatchInfo where ppr ConLike = ptext (sLit "CONLIKE") ppr FunLike = ptext (sLit "FUNLIKE") -instance Outputable InlinePragma where - ppr (InlinePragma activation FunLike) - = ppr activation - ppr (InlinePragma activation match_info) - = ppr match_info <+> ppr activation - instance Outputable InlineSpec where - ppr (Inline (InlinePragma act match_info) is_inline) - | is_inline = ptext (sLit "INLINE") - <+> ppr_match_info - <+> case act of - AlwaysActive -> empty - _ -> ppr act - | otherwise = ptext (sLit "NOINLINE") - <+> ppr_match_info - <+> case act of - NeverActive -> empty - _ -> ppr act - where - ppr_match_info = if isFunLike match_info then empty else ppr match_info + ppr Inline = ptext (sLit "INLINE") + ppr NoInline = ptext (sLit "NOINLINE") + ppr Inlinable = ptext (sLit "INLINABLE") + ppr EmptyInlineSpec = empty -isActive :: CompilerPhase -> Activation -> Bool -isActive _ NeverActive = False -isActive _ AlwaysActive = True -isActive p (ActiveAfter n) = p <= n -isActive p (ActiveBefore n) = p > n +instance Outputable InlinePragma where + ppr (InlinePragma { inl_inline = inline, inl_act = activation + , inl_rule = info, inl_sat = mb_arity }) + = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info + where + pp_act Inline AlwaysActive = empty + pp_act NoInline NeverActive = empty + pp_act _ act = 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 -isNeverActive, isAlwaysActive :: Activation -> Bool +isActive :: CompilerPhase -> Activation -> Bool +isActive InitialPhase AlwaysActive = True +isActive InitialPhase (ActiveBefore {}) = True +isActive InitialPhase _ = False +isActive (Phase p) act = isActiveIn p act + +isActiveIn :: PhaseNum -> Activation -> Bool +isActiveIn _ NeverActive = False +isActiveIn _ AlwaysActive = True +isActiveIn p (ActiveAfter n) = p <= n +isActiveIn p (ActiveBefore n) = p > n + +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} + + +\begin{code} +-- Used (instead of Rational) to represent exactly the floating point literal that we +-- encountered in the user's source program. This allows us to pretty-print exactly what +-- the user wrote, which is important e.g. for floating point numbers that can't represented +-- as Doubles (we used to via Double for pretty-printing). See also #2245. +data FractionalLit + = FL { fl_text :: String -- How the value was written in the source + , fl_value :: Rational -- Numeric value of the literal + } + deriving (Data, Typeable) + +negateFractionalLit :: FractionalLit -> FractionalLit +negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value } +negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value } + +integralFractionalLit :: Integer -> FractionalLit +integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i } + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module MatchLit) + +instance Eq FractionalLit where + (==) = (==) `on` fl_value + +instance Ord FractionalLit where + compare = compare `on` fl_value + +instance Outputable FractionalLit where + ppr = text . fl_text +\end{code}