X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FBasicTypes.lhs;h=41a5fa55bd4ed8e15cef7739deb7a77e8e91d998;hp=3a882a707a11be2e825be63acb59f55d794f38b5;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=023b31fe82746b937ab0eba78b11559be782ebcf diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 3a882a7..41a5fa5 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, @@ -52,7 +54,8 @@ module BasicTypes( EP(..), - StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, + HsBang(..), isBanged, isMarkedUnboxed, + StrictnessMark(..), isMarkedStrict, CompilerPhase, Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive, @@ -67,6 +70,8 @@ module BasicTypes( import FastString import Outputable + +import Data.Data hiding (Fixity) \end{code} %************************************************************************ @@ -87,7 +92,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)" @@ -122,7 +127,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)) @@ -141,8 +146,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 @@ -173,6 +179,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] @@ -182,7 +189,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") @@ -263,7 +270,7 @@ instance Outputable TopLevelFlag where data Boxity = Boxed | Unboxed - deriving( Eq ) + deriving( Eq, Data, Typeable ) isBoxed :: Boxity -> Bool isBoxed Boxed = True @@ -280,7 +287,7 @@ isBoxed Unboxed = False \begin{code} data RecFlag = Recursive | NonRecursive - deriving( Eq ) + deriving( Eq, Data, Typeable ) isRec :: RecFlag -> Bool isRec Recursive = True @@ -523,24 +530,46 @@ 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} @@ -587,11 +616,11 @@ 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 @@ -601,7 +630,7 @@ data InlinePragma -- Note [InlinePragma] -- 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] @@ -673,8 +702,13 @@ defaultInlinePragma = InlinePragma { inl_act = AlwaysActive alwaysInlinePragma = defaultInlinePragma { inl_inline = True } neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } -dfunInlinePragma = defaultInlinePragma { inl_rule = ConLike } - + +-- 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 @@ -701,8 +735,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) @@ -713,18 +747,18 @@ instance Outputable RuleMatchInfo where instance Outputable InlinePragma where ppr (InlinePragma { inl_inline = inline, inl_act = activation , inl_rule = info, inl_sat = mb_arity }) - = pp_inline <> pp_activation <+> pp_sat <+> pp_info + = 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