X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FBasicTypes.lhs;h=8fcf5ca77725bb6f72154964c62eb8be229e6d4d;hp=6b662bd6a64c18c590d9dc541187fe88e13d1c79;hb=6084fb5517da34f65034370a3695e2af3b85ce2b;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 6b662bd..8fcf5ca 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 % \section[BasicTypes]{Miscellanous types} @@ -18,7 +19,7 @@ module BasicTypes( Arity, - DeprecTxt, + WarningTxt(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, @@ -29,14 +30,18 @@ module BasicTypes( RecFlag(..), isRec, isNonRec, boolToRecFlag, + RuleName, + TopLevelFlag(..), isTopLevel, isNotTopLevel, + OverlapFlag(..), + Boxity(..), isBoxed, TupCon(..), tupleParens, OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, - isDeadOcc, isLoopBreaker, isNoOcc, + isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, @@ -53,9 +58,7 @@ module BasicTypes( SuccessFlag(..), succeeded, failed, successIf ) where -#include "HsVersions.h" - -import FastString( FastString ) +import FastString import Outputable \end{code} @@ -94,7 +97,14 @@ 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 w) = doubleQuotes (ftext w) + ppr (DeprecatedTxt d) = text "Deprecated:" <+> doubleQuotes (ftext d) \end{code} %************************************************************************ @@ -107,26 +117,29 @@ The @IPName@ type is here because it is used in TypeRep (i.e. very early in the hierarchy), but also in HsSyn. \begin{code} -data IPName name - = Dupable name -- ?x: you can freely duplicate this implicit parameter - | Linear name -- %x: you must use the splitting function to duplicate it +newtype IPName name = IPName name -- ?x deriving( Eq, Ord ) -- Ord is used in the IP name cache finite map -- (used in HscTypes.OrigIParamCache) - ipNameName :: IPName name -> name -ipNameName (Dupable n) = n -ipNameName (Linear n) = n +ipNameName (IPName n) = n mapIPName :: (a->b) -> IPName a -> IPName b -mapIPName f (Dupable n) = Dupable (f n) -mapIPName f (Linear n) = Linear (f n) +mapIPName f (IPName n) = IPName (f n) instance Outputable name => Outputable (IPName name) where - ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters - ppr (Linear n) = char '%' <> ppr n -- Splittable implicit parameters + ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters \end{code} +%************************************************************************ +%* * + Rules +%* * +%************************************************************************ + +\begin{code} +type RuleName = FastString +\end{code} %************************************************************************ %* * @@ -149,12 +162,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 @@ -210,14 +225,14 @@ 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} %************************************************************************ %* * -\subsection[Top-level/local]{Top-level/not-top level flag} + Top-level/not-top level flag %* * %************************************************************************ @@ -235,11 +250,11 @@ isBoxed Unboxed = False %************************************************************************ %* * -\subsection[Recursive/Non-Recursive]{Recursive/Non-Recursive flag} + Recursive/Non-Recursive flag %* * %************************************************************************ -\begin{code} +\begin{code} data RecFlag = Recursive | NonRecursive deriving( Eq ) @@ -257,8 +272,49 @@ 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} + +%************************************************************************ +%* * + Instance overlap flag +%* * +%************************************************************************ + +\begin{code} +data OverlapFlag + = NoOverlap -- This instance must not overlap another + + | OverlapOk -- Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- 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 + -- its ambiguous which to choose) + + | Incoherent -- Like OverlapOk, but also ignore this instance + -- if it doesn't match the constraint you are + -- trying to resolve, but could match if the type variables + -- in the constraint were instantiated + -- + -- Example: constraint (Foo [b]) + -- instances (Foo [Int]) Incoherent + -- (Foo [a]) + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen + deriving( Eq ) + +instance Outputable OverlapFlag where + ppr NoOverlap = empty + ppr OverlapOk = ptext (sLit "[overlap ok]") + ppr Incoherent = ptext (sLit "[incoherent]") + \end{code} %************************************************************************ @@ -275,7 +331,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} %************************************************************************ @@ -327,22 +383,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 + = 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 !InsideLam - !OneBranch - !InterestingCxt + | OneOcc + !InsideLam + !OneBranch + !InterestingCxt -- ^ Occurs exactly once, not inside a rule + + -- | 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). - | IAmALoopBreaker -- Used by the occurrence analyser to mark loop-breakers - -- in a group of recursive definitions +\begin{code} isNoOcc :: OccInfo -> Bool isNoOcc NoOccInfo = True -isNoOcc other = False +isNoOcc _ = False seqOccInfo :: OccInfo -> () seqOccInfo occ = occ `seq` () @@ -356,39 +435,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 (IAmALoopBreaker _) = True +isLoopBreaker _ = False + +isNonRuleLoopBreaker :: OccInfo -> Bool +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 = ptext SLIT("LoopBreaker") - ppr IAmDead = ptext SLIT("Dead") + ppr NoOccInfo = empty + 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 @@ -417,16 +503,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} @@ -439,6 +527,10 @@ instance Outputable StrictnessMark where \begin{code} data SuccessFlag = Succeeded | Failed +instance Outputable SuccessFlag where + ppr Succeeded = ptext (sLit "Succeeded") + ppr Failed = ptext (sLit "Failed") + successIf :: Bool -> SuccessFlag successIf True = Succeeded successIf False = Failed @@ -478,31 +570,40 @@ data InlineSpec -- is enabled, it will definitely actually happen deriving( Eq ) +defaultInlineSpec, alwaysInlineSpec, neverInlineSpec :: InlineSpec + defaultInlineSpec = Inline AlwaysActive False -- Inlining is OK, but not forced alwaysInlineSpec = Inline AlwaysActive True -- INLINE always neverInlineSpec = Inline NeverActive False -- NOINLINE instance Outputable Activation where - ppr AlwaysActive = empty -- The default + ppr NeverActive = ptext (sLit "NEVER") + ppr AlwaysActive = ptext (sLit "ALWAYS") 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 + ppr (Inline act is_inline) + | is_inline = ptext (sLit "INLINE") + <> case act of + AlwaysActive -> empty + _ -> ppr act + | otherwise = ptext (sLit "NOINLINE") + <> case act of + NeverActive -> empty + _ -> ppr act 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 NeverActive = True -isNeverActive act = False +isNeverActive _ = False isAlwaysActive AlwaysActive = True -isAlwaysActive other = False +isAlwaysActive _ = False \end{code}