X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FBasicTypes.lhs;h=cb08941c0c95dc303aca9b5925031853a65c79a4;hb=2df439cce75fec8c3620f88ee193c06f2a766050;hp=0f7a462b4b060284cb7bc649f0aed31637465781;hpb=f6cd95ff9a2bddbd78682dcd9287aec7d152cc13;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 0f7a462..cb08941 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -17,32 +17,47 @@ module BasicTypes( Version, bumpVersion, initialVersion, bogusVersion, Arity, + + DeprecTxt, Unused, unused, Fixity(..), FixityDirection(..), - defaultFixity, maxPrecedence, negateFixity, negatePrecedence, + defaultFixity, maxPrecedence, + arrowFixity, negateFixity, negatePrecedence, + compareFixity, + + IPName(..), ipNameName, mapIPName, NewOrData(..), - RecFlag(..), isRec, isNonRec, + RecFlag(..), isRec, isNonRec, boolToRecFlag, TopLevelFlag(..), isTopLevel, isNotTopLevel, - Boxity(..), isBoxed, tupleParens, + Boxity(..), isBoxed, + + TupCon(..), tupParens, tupleParens, - OccInfo(..), seqOccInfo, isFragileOcc, isDeadOcc, isLoopBreaker, + OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, + isDeadOcc, isLoopBreaker, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, EP(..), - StrictnessMark(..), isMarkedUnboxed, isMarkedStrict + StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, + + CompilerPhase, + Activation(..), isActive, isNeverActive, isAlwaysActive, + + SuccessFlag(..), succeeded, failed, successIf ) where #include "HsVersions.h" +import FastString( FastString ) import Outputable \end{code} @@ -85,15 +100,54 @@ type Version = Int bogusVersion :: Version -- Shouldn't look at these bogusVersion = error "bogusVersion" -bumpVersion :: Bool -> Version -> Version --- Bump if the predicate (typically equality between old and new) is false -bumpVersion False v = v+1 -bumpVersion True v = v +bumpVersion :: Version -> Version +bumpVersion v = v+1 initialVersion :: Version initialVersion = 1 \end{code} +%************************************************************************ +%* * + Deprecations +%* * +%************************************************************************ + + +\begin{code} +type DeprecTxt = FastString -- reason/explanation for deprecation +\end{code} + +%************************************************************************ +%* * +\subsection{Implicit parameter identity} +%* * +%************************************************************************ + +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 + 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 + +mapIPName :: (a->b) -> IPName a -> IPName b +mapIPName f (Dupable n) = Dupable (f n) +mapIPName f (Linear n) = Linear (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 +\end{code} + %************************************************************************ %* * @@ -102,31 +156,64 @@ initialVersion = 1 %************************************************************************ \begin{code} +------------------------ data Fixity = Fixity Int FixityDirection -data FixityDirection = InfixL | InfixR | InfixN - deriving(Eq) instance Outputable Fixity where ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] +instance Eq Fixity where -- Used to determine if two fixities conflict + (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 + +------------------------ +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") -instance Eq Fixity where -- Used to determine if two fixities conflict - (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 - +------------------------ maxPrecedence = (9::Int) defaultFixity = Fixity maxPrecedence InfixL negateFixity :: Fixity negateFixity = Fixity negatePrecedence InfixL -- Precedence of unary negate is wired in as infixl 6! +arrowFixity :: Fixity -- Fixity of '->' in types +arrowFixity = Fixity 0 InfixR + negatePrecedence :: Int negatePrecedence = 6 \end{code} +Consider + +\begin{verbatim} + a `op1` b `op2` c +\end{verbatim} +@(compareFixity op1 op2)@ tells which way to arrange appication, or +whether there's an error. + +\begin{code} +compareFixity :: Fixity -> Fixity + -> (Bool, -- Error please + Bool) -- Associate to the right: a op1 (b op2 c) +compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) + = case prec1 `compare` prec2 of + GT -> left + LT -> right + EQ -> case (dir1, dir2) of + (InfixR, InfixR) -> right + (InfixL, InfixL) -> left + _ -> error_please + where + right = (False, True) + left = (False, False) + error_please = (True, False) +\end{code} + %************************************************************************ %* * @@ -139,8 +226,13 @@ data NewOrData = NewType -- "newtype Blah ..." | DataType -- "data Blah ..." deriving( Eq ) -- Needed because Demand derives Eq + +instance Outputable NewOrData where + ppr NewType = ptext SLIT("newtype") + ppr DataType = ptext SLIT("data") \end{code} + %************************************************************************ %* * \subsection[Top-level/local]{Top-level/not-top level flag} @@ -159,8 +251,13 @@ isNotTopLevel TopLevel = False isTopLevel TopLevel = True isTopLevel NotTopLevel = False + +instance Outputable TopLevelFlag where + ppr TopLevel = ptext SLIT("") + ppr NotTopLevel = ptext SLIT("") \end{code} + %************************************************************************ %* * \subsection[Top-level/local]{Top-level/not-top level flag} @@ -176,10 +273,6 @@ data Boxity isBoxed :: Boxity -> Bool isBoxed Boxed = True isBoxed Unboxed = False - -tupleParens :: Boxity -> SDoc -> SDoc -tupleParens Boxed p = parens p -tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)") \end{code} @@ -192,6 +285,7 @@ tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)") \begin{code} data RecFlag = Recursive | NonRecursive + deriving( Eq ) isRec :: RecFlag -> Bool isRec Recursive = True @@ -200,6 +294,34 @@ isRec NonRecursive = False isNonRec :: RecFlag -> Bool isNonRec Recursive = False isNonRec NonRecursive = True + +boolToRecFlag :: Bool -> RecFlag +boolToRecFlag True = Recursive +boolToRecFlag False = NonRecursive + +instance Outputable RecFlag where + ppr Recursive = ptext SLIT("Recursive") + ppr NonRecursive = ptext SLIT("NonRecursive") +\end{code} + +%************************************************************************ +%* * + Tuples +%* * +%************************************************************************ + +\begin{code} +data TupCon = TupCon Boxity Arity + +instance Eq TupCon where + (TupCon b1 a1) == (TupCon b2 a2) = b1==b2 && a1==a2 + +tupParens :: TupCon -> SDoc -> SDoc +tupParens (TupCon b _) p = tupleParens b p + +tupleParens :: Boxity -> SDoc -> SDoc +tupleParens Boxed p = parens p +tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)") \end{code} %************************************************************************ @@ -209,7 +331,7 @@ isNonRec NonRecursive = True %************************************************************************ This is the "Embedding-Projection pair" datatype, it contains -two pieces of code (normally either RenamedHsExpr's or Id's) +two pieces of code (normally either RenamedExpr's or Id's) If we have a such a pair (EP from to), the idea is that 'from' and 'to' represents functions of type @@ -287,9 +409,12 @@ isDeadOcc :: OccInfo -> Bool isDeadOcc IAmDead = True isDeadOcc other = False +isOneOcc (OneOcc _ _) = True +isOneOcc other = False + isFragileOcc :: OccInfo -> Bool isFragileOcc (OneOcc _ _) = True -isFragileOcc other = False +isFragileOcc other = False \end{code} \begin{code} @@ -316,11 +441,10 @@ The strictness annotations on types in data type declarations e.g. data T = MkT !Int !(Bool,Bool) \begin{code} -data StrictnessMark - = MarkedUserStrict -- "!" in a source decl - | MarkedStrict -- "!" in an interface decl: strict but not unboxed - | MarkedUnboxed -- "!!" in an interface decl: unboxed - | NotMarkedStrict -- No annotation at all +data StrictnessMark -- Used in interface decls only + = MarkedStrict + | MarkedUnboxed + | NotMarkedStrict deriving( Eq ) isMarkedUnboxed MarkedUnboxed = True @@ -330,8 +454,70 @@ isMarkedStrict NotMarkedStrict = False isMarkedStrict other = True -- All others are strict instance Outputable StrictnessMark where - ppr MarkedUserStrict = ptext SLIT("!u") ppr MarkedStrict = ptext SLIT("!") - ppr MarkedUnboxed = ptext SLIT("! !") - ppr NotMarkedStrict = empty + ppr MarkedUnboxed = ptext SLIT("!!") + ppr NotMarkedStrict = ptext SLIT("_") \end{code} + + +%************************************************************************ +%* * +\subsection{Success flag} +%* * +%************************************************************************ + +\begin{code} +data SuccessFlag = Succeeded | Failed + +successIf :: Bool -> SuccessFlag +successIf True = Succeeded +successIf False = Failed + +succeeded, failed :: SuccessFlag -> Bool +succeeded Succeeded = True +succeeded Failed = False + +failed Succeeded = False +failed Failed = True +\end{code} + + +%************************************************************************ +%* * +\subsection{Activation} +%* * +%************************************************************************ + +When a rule or inlining is active + +\begin{code} +type CompilerPhase = Int -- Compilation phase + -- Phases decrease towards zero + -- Zero is the last phase + +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 + +instance Outputable Activation where + ppr AlwaysActive = empty -- The default + ppr (ActiveBefore n) = brackets (char '~' <> int n) + ppr (ActiveAfter n) = brackets (int n) + ppr NeverActive = ptext SLIT("NEVER") + +isActive :: CompilerPhase -> Activation -> Bool +isActive p NeverActive = False +isActive p AlwaysActive = True +isActive p (ActiveAfter n) = p <= n +isActive p (ActiveBefore n) = p > n + +isNeverActive, isAlwaysActive :: Activation -> Bool +isNeverActive NeverActive = True +isNeverActive act = False + +isAlwaysActive AlwaysActive = True +isAlwaysActive other = False +\end{code} +