X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FBasicTypes.lhs;h=a76ee64a80ae6a491b03458744f8b2cdad6e32ea;hp=33c65980ec657643cc52e0689a7311df82177aed;hb=3391a03562d4056de7b16cd0f632e6c43ae44cca;hpb=f278f0676579f67075033a4f9857715909c4b71e diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 33c6598..a76ee64 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -21,7 +21,7 @@ module BasicTypes( Arity, - FunctionOrData(..), + FunctionOrData(..), WarningTxt(..), @@ -54,23 +54,34 @@ module BasicTypes( EP(..), - StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, + HsBang(..), isBanged, isMarkedUnboxed, + StrictnessMark(..), isMarkedStrict, - CompilerPhase, - Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive, + DefMethSpec(..), + + CompilerPhase(..), PhaseNum, + Activation(..), isActive, isActiveIn, + isNeverActive, isAlwaysActive, isEarlyActive, RuleMatchInfo(..), isConLike, isFunLike, - InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma, - isDefaultInlinePragma, isInlinePragma, inlinePragmaSat, + InlineSpec(..), + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, + neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, + isInlinePragma, isInlinablePragma, isAnyInlinePragma, + inlinePragmaSpec, inlinePragmaSat, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, - SuccessFlag(..), succeeded, failed, successIf + SuccessFlag(..), succeeded, failed, successIf, + + FractionalLit(..) ) where import FastString import Outputable import Data.Data hiding (Fixity) +import Data.Function (on) \end{code} %************************************************************************ @@ -321,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 @@ -521,7 +533,7 @@ instance Show OccInfo where %************************************************************************ %* * -\subsection{Strictness indication} + Strictness indication %* * %************************************************************************ @@ -529,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} %* * %************************************************************************ @@ -585,29 +641,52 @@ 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, Data, Typeable ) -- 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 -- See Note [CONLIKE pragma] | FunLike - deriving( Eq, Data, Typeable ) + deriving( Eq, Data, Typeable, Show ) + -- Show needed for Lexer.x data InlinePragma -- Note [InlinePragma] = InlinePragma - { inl_inline :: Bool -- True <=> INLINE, - -- False <=> no pragma at all, or NOINLINE + { 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] @@ -670,16 +749,23 @@ isFunLike :: RuleMatchInfo -> Bool isFunLike FunLike = True isFunLike _ = False +isEmptyInlineSpec :: InlineSpec -> Bool +isEmptyInlineSpec EmptyInlineSpec = True +isEmptyInlineSpec _ = False + defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma defaultInlinePragma = InlinePragma { inl_act = AlwaysActive , inl_rule = FunLike - , inl_inline = False + , inl_inline = EmptyInlineSpec , inl_sat = Nothing } -alwaysInlinePragma = defaultInlinePragma { inl_inline = True } +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 @@ -691,11 +777,25 @@ isDefaultInlinePragma :: InlinePragma -> Bool isDefaultInlinePragma (InlinePragma { inl_act = activation , inl_rule = match_info , inl_inline = inline }) - = not inline && isAlwaysActive activation && isFunLike match_info + = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info isInlinePragma :: InlinePragma -> Bool -isInlinePragma prag = inl_inline prag - +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 @@ -721,16 +821,20 @@ instance Outputable RuleMatchInfo where ppr ConLike = ptext (sLit "CONLIKE") ppr FunLike = ptext (sLit "FUNLIKE") +instance Outputable InlineSpec where + ppr Inline = ptext (sLit "INLINE") + ppr NoInline = ptext (sLit "NOINLINE") + ppr Inlinable = ptext (sLit "INLINABLE") + ppr EmptyInlineSpec = empty + instance Outputable InlinePragma where ppr (InlinePragma { inl_inline = inline, inl_act = activation , inl_rule = info, inl_sat = mb_arity }) - = pp_inl_act (inline, activation) <+> pp_sat <+> pp_info + = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info where - 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_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 @@ -738,10 +842,16 @@ instance Outputable InlinePragma where | otherwise = ppr info isActive :: CompilerPhase -> Activation -> Bool -isActive _ NeverActive = False -isActive _ AlwaysActive = True -isActive p (ActiveAfter n) = p <= n -isActive p (ActiveBefore n) = p > n +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 @@ -755,3 +865,25 @@ isEarlyActive (ActiveBefore {}) = True isEarlyActive _ = False \end{code} + + +\begin{code} +-- Used 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) + +-- 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 +\end{code}