diff options
Diffstat (limited to 'compiler/basicTypes')
38 files changed, 8290 insertions, 0 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs new file mode 100644 index 0000000000..6b662bd6a6 --- /dev/null +++ b/compiler/basicTypes/BasicTypes.lhs @@ -0,0 +1,508 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 +% +\section[BasicTypes]{Miscellanous types} + +This module defines a miscellaneously collection of very simple +types that + +\begin{itemize} +\item have no other obvious home +\item don't depend on any other complicated types +\item are used in more than one "part" of the compiler +\end{itemize} + +\begin{code} +module BasicTypes( + Version, bumpVersion, initialVersion, + + Arity, + + DeprecTxt, + + Fixity(..), FixityDirection(..), + defaultFixity, maxPrecedence, + negateFixity, funTyFixity, + compareFixity, + + IPName(..), ipNameName, mapIPName, + + RecFlag(..), isRec, isNonRec, boolToRecFlag, + + TopLevelFlag(..), isTopLevel, isNotTopLevel, + + Boxity(..), isBoxed, + + TupCon(..), tupleParens, + + OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, + isDeadOcc, isLoopBreaker, isNoOcc, + + InsideLam, insideLam, notInsideLam, + OneBranch, oneBranch, notOneBranch, + InterestingCxt, + + EP(..), + + StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, + + CompilerPhase, + Activation(..), isActive, isNeverActive, isAlwaysActive, + InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec, + + SuccessFlag(..), succeeded, failed, successIf + ) where + +#include "HsVersions.h" + +import FastString( FastString ) +import Outputable +\end{code} + +%************************************************************************ +%* * +\subsection[Arity]{Arity} +%* * +%************************************************************************ + +\begin{code} +type Arity = Int +\end{code} + + +%************************************************************************ +%* * +\subsection[Version]{Module and identifier version numbers} +%* * +%************************************************************************ + +\begin{code} +type Version = Int + +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} + + +%************************************************************************ +%* * +\subsection[Fixity]{Fixity info} +%* * +%************************************************************************ + +\begin{code} +------------------------ +data Fixity = Fixity Int FixityDirection + +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") + +------------------------ +maxPrecedence = (9::Int) +defaultFixity = Fixity maxPrecedence InfixL + +negateFixity, funTyFixity :: Fixity +-- Wired-in fixities +negateFixity = Fixity 6 InfixL -- Fixity of unary negate +funTyFixity = Fixity 0 InfixR -- Fixity of '->' +\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} + + +%************************************************************************ +%* * +\subsection[Top-level/local]{Top-level/not-top level flag} +%* * +%************************************************************************ + +\begin{code} +data TopLevelFlag + = TopLevel + | NotTopLevel + +isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool + +isNotTopLevel NotTopLevel = True +isNotTopLevel TopLevel = False + +isTopLevel TopLevel = True +isTopLevel NotTopLevel = False + +instance Outputable TopLevelFlag where + ppr TopLevel = ptext SLIT("<TopLevel>") + ppr NotTopLevel = ptext SLIT("<NotTopLevel>") +\end{code} + + +%************************************************************************ +%* * +\subsection[Top-level/local]{Top-level/not-top level flag} +%* * +%************************************************************************ + +\begin{code} +data Boxity + = Boxed + | Unboxed + deriving( Eq ) + +isBoxed :: Boxity -> Bool +isBoxed Boxed = True +isBoxed Unboxed = False +\end{code} + + +%************************************************************************ +%* * +\subsection[Recursive/Non-Recursive]{Recursive/Non-Recursive flag} +%* * +%************************************************************************ + +\begin{code} +data RecFlag = Recursive + | NonRecursive + deriving( Eq ) + +isRec :: RecFlag -> Bool +isRec Recursive = True +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 + +tupleParens :: Boxity -> SDoc -> SDoc +tupleParens Boxed p = parens p +tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)") +\end{code} + +%************************************************************************ +%* * +\subsection[Generic]{Generic flag} +%* * +%************************************************************************ + +This is the "Embedding-Projection pair" datatype, it contains +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 + + from :: T -> Tring + to :: Tring -> T + +And we should have + + to (from x) = x + +T and Tring are arbitrary, but typically T is the 'main' type while +Tring is the 'representation' type. (This just helps us remember +whether to use 'from' or 'to'. + +\begin{code} +data EP a = EP { fromEP :: a, -- :: T -> Tring + toEP :: a } -- :: Tring -> T +\end{code} + +Embedding-projection pairs are used in several places: + +First of all, each type constructor has an EP associated with it, the +code in EP converts (datatype T) from T to Tring and back again. + +Secondly, when we are filling in Generic methods (in the typechecker, +tcMethodBinds), we are constructing bimaps by induction on the structure +of the type of the method signature. + + +%************************************************************************ +%* * +\subsection{Occurrence information} +%* * +%************************************************************************ + +This data type is used exclusively by the simplifier, but it appears in a +SubstResult, which is currently defined in VarEnv, which is pretty near +the base of the module hierarchy. So it seemed simpler to put the +defn of OccInfo here, safely at the bottom + +\begin{code} +data OccInfo + = NoOccInfo + + | IAmDead -- Marks unused variables. Sometimes useful for + -- lambda and case-bound variables. + + | OneOcc !InsideLam + !OneBranch + !InterestingCxt + + | IAmALoopBreaker -- Used by the occurrence analyser to mark loop-breakers + -- in a group of recursive definitions + +isNoOcc :: OccInfo -> Bool +isNoOcc NoOccInfo = True +isNoOcc other = False + +seqOccInfo :: OccInfo -> () +seqOccInfo occ = occ `seq` () + +----------------- +type InterestingCxt = Bool -- True <=> Function: is applied + -- Data value: scrutinised by a case with + -- at least one non-DEFAULT branch + +----------------- +type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda + -- Substituting a redex for this occurrence is + -- dangerous because it might duplicate work. +insideLam = True +notInsideLam = False + +----------------- +type OneBranch = Bool -- True <=> Occurs in only one case branch + -- so no code-duplication issue to worry about +oneBranch = True +notOneBranch = False + +isLoopBreaker :: OccInfo -> Bool +isLoopBreaker IAmALoopBreaker = True +isLoopBreaker other = False + +isDeadOcc :: OccInfo -> Bool +isDeadOcc IAmDead = True +isDeadOcc other = False + +isOneOcc (OneOcc _ _ _) = True +isOneOcc other = False + +isFragileOcc :: OccInfo -> Bool +isFragileOcc (OneOcc _ _ _) = True +isFragileOcc other = 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 (OneOcc inside_lam one_branch int_cxt) + = ptext SLIT("Once") <> pp_lam <> pp_br <> pp_args + where + pp_lam | inside_lam = char 'L' + | otherwise = empty + pp_br | one_branch = empty + | otherwise = char '*' + pp_args | int_cxt = char '!' + | otherwise = empty + +instance Show OccInfo where + showsPrec p occ = showsPrecSDoc p (ppr occ) +\end{code} + +%************************************************************************ +%* * +\subsection{Strictness indication} +%* * +%************************************************************************ + +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 ) + +isMarkedUnboxed MarkedUnboxed = True +isMarkedUnboxed other = False + +isMarkedStrict NotMarkedStrict = False +isMarkedStrict other = True -- All others are strict + +instance Outputable StrictnessMark where + ppr MarkedStrict = ptext SLIT("!") + 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 + +data InlineSpec + = Inline + Activation -- Says during which phases inlining is allowed + Bool -- True <=> make the RHS look small, so that when inlining + -- is enabled, it will definitely actually happen + deriving( Eq ) + +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 (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 + +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} + diff --git a/compiler/basicTypes/DataCon.hi-boot-5 b/compiler/basicTypes/DataCon.hi-boot-5 new file mode 100644 index 0000000000..f5a8a2d6a8 --- /dev/null +++ b/compiler/basicTypes/DataCon.hi-boot-5 @@ -0,0 +1,5 @@ +__interface DataCon 1 0 where +__export DataCon DataCon isExistentialDataCon dataConName ; +1 data DataCon ; +1 isExistentialDataCon :: DataCon -> PrelBase.Bool ; +1 dataConName :: DataCon -> Name.Name ; diff --git a/compiler/basicTypes/DataCon.hi-boot-6 b/compiler/basicTypes/DataCon.hi-boot-6 new file mode 100644 index 0000000000..7882469bce --- /dev/null +++ b/compiler/basicTypes/DataCon.hi-boot-6 @@ -0,0 +1,5 @@ +module DataCon where + +data DataCon +dataConName :: DataCon -> Name.Name +isVanillaDataCon :: DataCon -> GHC.Base.Bool diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs new file mode 100644 index 0000000000..805ef73c59 --- /dev/null +++ b/compiler/basicTypes/DataCon.lhs @@ -0,0 +1,632 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1998 +% +\section[DataCon]{@DataCon@: Data Constructors} + +\begin{code} +module DataCon ( + DataCon, DataConIds(..), + ConTag, fIRST_TAG, + mkDataCon, + dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon, + dataConTyVars, dataConResTys, + dataConStupidTheta, + dataConInstArgTys, dataConOrigArgTys, dataConInstResTy, + dataConInstOrigArgTys, dataConRepArgTys, + dataConFieldLabels, dataConFieldType, + dataConStrictMarks, dataConExStricts, + dataConSourceArity, dataConRepArity, + dataConIsInfix, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, + dataConRepStrictness, + isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon, + isVanillaDataCon, classDataCon, + + splitProductType_maybe, splitProductType, + ) where + +#include "HsVersions.h" + +import Type ( Type, ThetaType, substTyWith, substTy, zipOpenTvSubst, + mkForAllTys, mkFunTys, mkTyConApp, + splitTyConApp_maybe, + mkPredTys, isStrictPred, pprType + ) +import TyCon ( TyCon, FieldLabel, tyConDataCons, + isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon ) +import Class ( Class, classTyCon ) +import Name ( Name, NamedThing(..), nameUnique ) +import Var ( TyVar, Id ) +import BasicTypes ( Arity, StrictnessMark(..) ) +import Outputable +import Unique ( Unique, Uniquable(..) ) +import ListSetOps ( assoc ) +import Util ( zipEqual, zipWithEqual ) +import Maybes ( expectJust ) +\end{code} + + +Data constructor representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following Haskell data type declaration + + data T = T !Int ![Int] + +Using the strictness annotations, GHC will represent this as + + data T = T Int# [Int] + +That is, the Int has been unboxed. Furthermore, the Haskell source construction + + T e1 e2 + +is translated to + + case e1 of { I# x -> + case e2 of { r -> + T x r }} + +That is, the first argument is unboxed, and the second is evaluated. Finally, +pattern matching is translated too: + + case e of { T a b -> ... } + +becomes + + case e of { T a' b -> let a = I# a' in ... } + +To keep ourselves sane, we name the different versions of the data constructor +differently, as follows. + + +Note [Data Constructor Naming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each data constructor C has two, and possibly three, Names associated with it: + + OccName Name space Used for + --------------------------------------------------------------------------- + * The "source data con" C DataName The DataCon itself + * The "real data con" C VarName Its worker Id + * The "wrapper data con" $WC VarName Wrapper Id (optional) + +Each of these three has a distinct Unique. The "source data con" name +appears in the output of the renamer, and names the Haskell-source +data constructor. The type checker translates it into either the wrapper Id +(if it exists) or worker Id (otherwise). + +The data con has one or two Ids associated with it: + + The "worker Id", is the actual data constructor. + Its type may be different to the Haskell source constructor + because: + - useless dict args are dropped + - strict args may be flattened + The worker is very like a primop, in that it has no binding. + + Newtypes have no worker Id + + + The "wrapper Id", $WC, whose type is exactly what it looks like + in the source program. It is an ordinary function, + and it gets a top-level binding like any other function. + + The wrapper Id isn't generated for a data type if the worker + and wrapper are identical. It's always generated for a newtype. + + + +A note about the stupid context +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Data types can have a context: + + data (Eq a, Ord b) => T a b = T1 a b | T2 a + +and that makes the constructors have a context too +(notice that T2's context is "thinned"): + + T1 :: (Eq a, Ord b) => a -> b -> T a b + T2 :: (Eq a) => a -> T a b + +Furthermore, this context pops up when pattern matching +(though GHC hasn't implemented this, but it is in H98, and +I've fixed GHC so that it now does): + + f (T2 x) = x +gets inferred type + f :: Eq a => T a b -> a + +I say the context is "stupid" because the dictionaries passed +are immediately discarded -- they do nothing and have no benefit. +It's a flaw in the language. + + Up to now [March 2002] I have put this stupid context into the + type of the "wrapper" constructors functions, T1 and T2, but + that turned out to be jolly inconvenient for generics, and + record update, and other functions that build values of type T + (because they don't have suitable dictionaries available). + + So now I've taken the stupid context out. I simply deal with + it separately in the type checker on occurrences of a + constructor, either in an expression or in a pattern. + + [May 2003: actually I think this decision could evasily be + reversed now, and probably should be. Generics could be + disabled for types with a stupid context; record updates now + (H98) needs the context too; etc. It's an unforced change, so + I'm leaving it for now --- but it does seem odd that the + wrapper doesn't include the stupid context.] + +[July 04] With the advent of generalised data types, it's less obvious +what the "stupid context" is. Consider + C :: forall a. Ord a => a -> a -> T (Foo a) +Does the C constructor in Core contain the Ord dictionary? Yes, it must: + + f :: T b -> Ordering + f = /\b. \x:T b. + case x of + C a (d:Ord a) (p:a) (q:a) -> compare d p q + +Note that (Foo a) might not be an instance of Ord. + +%************************************************************************ +%* * +\subsection{Data constructors} +%* * +%************************************************************************ + +\begin{code} +data DataCon + = MkData { + dcName :: Name, -- This is the name of the *source data con* + -- (see "Note [Data Constructor Naming]" above) + dcUnique :: Unique, -- Cached from Name + dcTag :: ConTag, + + -- Running example: + -- + -- data Eq a => T a = forall b. Ord b => MkT a [b] + + -- The next six fields express the type of the constructor, in pieces + -- e.g. + -- + -- dcTyVars = [a,b] + -- dcStupidTheta = [Eq a] + -- dcTheta = [Ord b] + -- dcOrigArgTys = [a,List b] + -- dcTyCon = T + -- dcTyArgs = [a,b] + + dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor + -- Its type is of form + -- forall a1..an . t1 -> ... tm -> T a1..an + -- No existentials, no GADTs, nothing. + -- + -- NB1: the order of the forall'd variables does matter; + -- for a vanilla constructor, we assume that if the result + -- type is (T t1 ... tn) then we can instantiate the constr + -- at types [t1, ..., tn] + -- + -- NB2: a vanilla constructor can still be declared in GADT-style + -- syntax, provided its type looks like the above. + + dcTyVars :: [TyVar], -- Universally-quantified type vars + -- for the data constructor. + -- See NB1 on dcVanilla for the conneciton between dcTyVars and dcResTys + -- + -- In general, the dcTyVars are NOT NECESSARILY THE SAME AS THE TYVARS + -- FOR THE PARENT TyCon. With GADTs the data con might not even have + -- the same number of type variables. + -- [This is a change (Oct05): previously, vanilla datacons guaranteed to + -- have the same type variables as their parent TyCon, but that seems ugly.] + + dcStupidTheta :: ThetaType, -- This is a "thinned" version of + -- the context of the data decl. + -- "Thinned", because the Report says + -- to eliminate any constraints that don't mention + -- tyvars free in the arg types for this constructor + -- + -- "Stupid", because the dictionaries aren't used for anything. + -- + -- Indeed, [as of March 02] they are no + -- longer in the type of the wrapper Id, because + -- that makes it harder to use the wrap-id to rebuild + -- values after record selection or in generics. + -- + -- Fact: the free tyvars of dcStupidTheta are a subset of + -- the free tyvars of dcResTys + -- Reason: dcStupidTeta is gotten by instantiating the + -- stupid theta from the tycon (see BuildTyCl.mkDataConStupidTheta) + + dcTheta :: ThetaType, -- The existentially quantified stuff + + dcOrigArgTys :: [Type], -- Original argument types + -- (before unboxing and flattening of + -- strict fields) + + -- Result type of constructor is T t1..tn + dcTyCon :: TyCon, -- Result tycon, T + dcResTys :: [Type], -- Result type args, t1..tn + + -- Now the strictness annotations and field labels of the constructor + dcStrictMarks :: [StrictnessMark], + -- Strictness annotations as decided by the compiler. + -- Does *not* include the existential dictionaries + -- length = dataConSourceArity dataCon + + dcFields :: [FieldLabel], + -- Field labels for this constructor, in the + -- same order as the argument types; + -- length = 0 (if not a record) or dataConSourceArity. + + -- Constructor representation + dcRepArgTys :: [Type], -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* existential dictionaries + + dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument + + dcRepType :: Type, -- Type of the constructor + -- forall a b . Ord b => a -> [b] -> MkT a + -- (this is *not* of the constructor wrapper Id: + -- see notes after this data type declaration) + -- + -- Notice that the existential type parameters come *second*. + -- Reason: in a case expression we may find: + -- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... } + -- It's convenient to apply the rep-type of MkT to 't', to get + -- forall b. Ord b => ... + -- and use that to check the pattern. Mind you, this is really only + -- use in CoreLint. + + + -- Finally, the curried worker function that corresponds to the constructor + -- It doesn't have an unfolding; the code generator saturates these Ids + -- and allocates a real constructor when it finds one. + -- + -- An entirely separate wrapper function is built in TcTyDecls + dcIds :: DataConIds, + + dcInfix :: Bool -- True <=> declared infix + -- Used for Template Haskell and 'deriving' only + -- The actual fixity is stored elsewhere + } + +data DataConIds + = NewDC Id -- Newtypes have only a wrapper, but no worker + | AlgDC (Maybe Id) Id -- Algebraic data types always have a worker, and + -- may or may not have a wrapper, depending on whether + -- the wrapper does anything. + + -- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments + + -- The wrapper takes dcOrigArgTys as its arguments + -- The worker takes dcRepArgTys as its arguments + -- If the worker is absent, dcRepArgTys is the same as dcOrigArgTys + + -- The 'Nothing' case of AlgDC is important + -- Not only is this efficient, + -- but it also ensures that the wrapper is replaced + -- by the worker (becuase it *is* the wroker) + -- even when there are no args. E.g. in + -- f (:) x + -- the (:) *is* the worker. + -- This is really important in rule matching, + -- (We could match on the wrappers, + -- but that makes it less likely that rules will match + -- when we bring bits of unfoldings together.) + +type ConTag = Int + +fIRST_TAG :: ConTag +fIRST_TAG = 1 -- Tags allocated from here for real constructors +\end{code} + +The dcRepType field contains the type of the representation of a contructor +This may differ from the type of the contructor *Id* (built +by MkId.mkDataConId) for two reasons: + a) the constructor Id may be overloaded, but the dictionary isn't stored + e.g. data Eq a => T a = MkT a a + + b) the constructor may store an unboxed version of a strict field. + +Here's an example illustrating both: + data Ord a => T a = MkT Int! a +Here + T :: Ord a => Int -> a -> T a +but the rep type is + Trep :: Int# -> a -> T a +Actually, the unboxed part isn't implemented yet! + + +%************************************************************************ +%* * +\subsection{Instances} +%* * +%************************************************************************ + +\begin{code} +instance Eq DataCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Ord DataCon where + a <= b = getUnique a <= getUnique b + a < b = getUnique a < getUnique b + a >= b = getUnique a >= getUnique b + a > b = getUnique a > getUnique b + compare a b = getUnique a `compare` getUnique b + +instance Uniquable DataCon where + getUnique = dcUnique + +instance NamedThing DataCon where + getName = dcName + +instance Outputable DataCon where + ppr con = ppr (dataConName con) + +instance Show DataCon where + showsPrec p con = showsPrecSDoc p (ppr con) +\end{code} + + +%************************************************************************ +%* * +\subsection{Construction} +%* * +%************************************************************************ + +\begin{code} +mkDataCon :: Name + -> Bool -- Declared infix + -> Bool -- Vanilla (see notes with dcVanilla) + -> [StrictnessMark] -> [FieldLabel] + -> [TyVar] -> ThetaType -> ThetaType + -> [Type] -> TyCon -> [Type] + -> DataConIds + -> DataCon + -- Can get the tag from the TyCon + +mkDataCon name declared_infix vanilla + arg_stricts -- Must match orig_arg_tys 1-1 + fields + tyvars stupid_theta theta orig_arg_tys tycon res_tys + ids + = con + where + con = MkData {dcName = name, + dcUnique = nameUnique name, dcVanilla = vanilla, + dcTyVars = tyvars, dcStupidTheta = stupid_theta, dcTheta = theta, + dcOrigArgTys = orig_arg_tys, dcTyCon = tycon, dcResTys = res_tys, + dcRepArgTys = rep_arg_tys, + dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts, + dcFields = fields, dcTag = tag, dcRepType = ty, + dcIds = ids, dcInfix = declared_infix} + + -- Strictness marks for source-args + -- *after unboxing choices*, + -- but *including existential dictionaries* + -- + -- The 'arg_stricts' passed to mkDataCon are simply those for the + -- source-language arguments. We add extra ones for the + -- dictionary arguments right here. + dict_tys = mkPredTys theta + real_arg_tys = dict_tys ++ orig_arg_tys + real_stricts = map mk_dict_strict_mark theta ++ arg_stricts + + -- Representation arguments and demands + (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys + + tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con + ty = mkForAllTys tyvars (mkFunTys rep_arg_tys result_ty) + -- NB: the existential dict args are already in rep_arg_tys + + result_ty = mkTyConApp tycon res_tys + +mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict + | otherwise = NotMarkedStrict +\end{code} + +\begin{code} +dataConName :: DataCon -> Name +dataConName = dcName + +dataConTag :: DataCon -> ConTag +dataConTag = dcTag + +dataConTyCon :: DataCon -> TyCon +dataConTyCon = dcTyCon + +dataConRepType :: DataCon -> Type +dataConRepType = dcRepType + +dataConIsInfix :: DataCon -> Bool +dataConIsInfix = dcInfix + +dataConTyVars :: DataCon -> [TyVar] +dataConTyVars = dcTyVars + +dataConWorkId :: DataCon -> Id +dataConWorkId dc = case dcIds dc of + AlgDC _ wrk_id -> wrk_id + NewDC _ -> pprPanic "dataConWorkId" (ppr dc) + +dataConWrapId_maybe :: DataCon -> Maybe Id +dataConWrapId_maybe dc = case dcIds dc of + AlgDC mb_wrap _ -> mb_wrap + NewDC wrap -> Just wrap + +dataConWrapId :: DataCon -> Id +-- Returns an Id which looks like the Haskell-source constructor +dataConWrapId dc = case dcIds dc of + AlgDC (Just wrap) _ -> wrap + AlgDC Nothing wrk -> wrk -- worker=wrapper + NewDC wrap -> wrap + +dataConImplicitIds :: DataCon -> [Id] +dataConImplicitIds dc = case dcIds dc of + AlgDC (Just wrap) work -> [wrap,work] + AlgDC Nothing work -> [work] + NewDC wrap -> [wrap] + +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConFieldLabels = dcFields + +dataConFieldType :: DataCon -> FieldLabel -> Type +dataConFieldType con label = expectJust "unexpected label" $ + lookup label (dcFields con `zip` dcOrigArgTys con) + +dataConStrictMarks :: DataCon -> [StrictnessMark] +dataConStrictMarks = dcStrictMarks + +dataConExStricts :: DataCon -> [StrictnessMark] +-- Strictness of *existential* arguments only +-- Usually empty, so we don't bother to cache this +dataConExStricts dc = map mk_dict_strict_mark (dcTheta dc) + +dataConSourceArity :: DataCon -> Arity + -- Source-level arity of the data constructor +dataConSourceArity dc = length (dcOrigArgTys dc) + +-- dataConRepArity gives the number of actual fields in the +-- {\em representation} of the data constructor. This may be more than appear +-- in the source code; the extra ones are the existentially quantified +-- dictionaries +dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys + +isNullarySrcDataCon, isNullaryRepDataCon :: DataCon -> Bool +isNullarySrcDataCon dc = null (dcOrigArgTys dc) +isNullaryRepDataCon dc = null (dcRepArgTys dc) + +dataConRepStrictness :: DataCon -> [StrictnessMark] + -- Give the demands on the arguments of a + -- Core constructor application (Con dc args) +dataConRepStrictness dc = dcRepStrictness dc + +dataConSig :: DataCon -> ([TyVar], ThetaType, + [Type], TyCon, [Type]) + +dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta, + dcOrigArgTys = arg_tys, dcTyCon = tycon, dcResTys = res_tys}) + = (tyvars, theta, arg_tys, tycon, res_tys) + +dataConStupidTheta :: DataCon -> ThetaType +dataConStupidTheta dc = dcStupidTheta dc + +dataConResTys :: DataCon -> [Type] +dataConResTys dc = dcResTys dc + +dataConInstArgTys :: DataCon + -> [Type] -- Instantiated at these types + -- NB: these INCLUDE the existentially quantified arg types + -> [Type] -- Needs arguments of these types + -- NB: these INCLUDE the existentially quantified dict args + -- but EXCLUDE the data-decl context which is discarded + -- It's all post-flattening etc; this is a representation type +dataConInstArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars}) inst_tys + = ASSERT( length tyvars == length inst_tys ) + map (substTyWith tyvars inst_tys) arg_tys + +dataConInstResTy :: DataCon -> [Type] -> Type +dataConInstResTy (MkData {dcTyVars = tyvars, dcTyCon = tc, dcResTys = res_tys}) inst_tys + = ASSERT( length tyvars == length inst_tys ) + substTy (zipOpenTvSubst tyvars inst_tys) (mkTyConApp tc res_tys) + -- res_tys can't currently contain any foralls, + -- but might in future; hence zipOpenTvSubst + +-- And the same deal for the original arg tys +dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] +dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars}) inst_tys + = ASSERT( length tyvars == length inst_tys ) + map (substTyWith tyvars inst_tys) arg_tys +\end{code} + +These two functions get the real argument types of the constructor, +without substituting for any type variables. + +dataConOrigArgTys returns the arg types of the wrapper, excluding all dictionary args. + +dataConRepArgTys retuns the arg types of the worker, including all dictionaries, and +after any flattening has been done. + +\begin{code} +dataConOrigArgTys :: DataCon -> [Type] +dataConOrigArgTys dc = dcOrigArgTys dc + +dataConRepArgTys :: DataCon -> [Type] +dataConRepArgTys dc = dcRepArgTys dc +\end{code} + + +\begin{code} +isTupleCon :: DataCon -> Bool +isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc + +isUnboxedTupleCon :: DataCon -> Bool +isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc + +isVanillaDataCon :: DataCon -> Bool +isVanillaDataCon dc = dcVanilla dc +\end{code} + + +\begin{code} +classDataCon :: Class -> DataCon +classDataCon clas = case tyConDataCons (classTyCon clas) of + (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr +\end{code} + +%************************************************************************ +%* * +\subsection{Splitting products} +%* * +%************************************************************************ + +\begin{code} +splitProductType_maybe + :: Type -- A product type, perhaps + -> Maybe (TyCon, -- The type constructor + [Type], -- Type args of the tycon + DataCon, -- The data constructor + [Type]) -- Its *representation* arg types + + -- Returns (Just ...) for any + -- concrete (i.e. constructors visible) + -- single-constructor + -- not existentially quantified + -- type whether a data type or a new type + -- + -- Rejecing existentials is conservative. Maybe some things + -- could be made to work with them, but I'm not going to sweat + -- it through till someone finds it's important. + +splitProductType_maybe ty + = case splitTyConApp_maybe ty of + Just (tycon,ty_args) + | isProductTyCon tycon -- Includes check for non-existential, + -- and for constructors visible + -> Just (tycon, ty_args, data_con, dataConInstArgTys data_con ty_args) + where + data_con = head (tyConDataCons tycon) + other -> Nothing + +splitProductType str ty + = case splitProductType_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic (str ++ ": not a product") (pprType ty) + + +computeRep :: [StrictnessMark] -- Original arg strictness + -> [Type] -- and types + -> ([StrictnessMark], -- Representation arg strictness + [Type]) -- And type + +computeRep stricts tys + = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys + where + unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)] + unbox MarkedStrict ty = [(MarkedStrict, ty)] + unbox MarkedUnboxed ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys + where + (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" ty +\end{code} diff --git a/compiler/basicTypes/DataCon.lhs-boot b/compiler/basicTypes/DataCon.lhs-boot new file mode 100644 index 0000000000..c5e05c9ecd --- /dev/null +++ b/compiler/basicTypes/DataCon.lhs-boot @@ -0,0 +1,8 @@ +\begin{code} +module DataCon where +import Name( Name ) + +data DataCon +dataConName :: DataCon -> Name +isVanillaDataCon :: DataCon -> Bool +\end{code} diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs new file mode 100644 index 0000000000..50bb0c6ffa --- /dev/null +++ b/compiler/basicTypes/Demand.lhs @@ -0,0 +1,208 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[Demand]{@Demand@: the amount of demand on a value} + +\begin{code} +#ifndef OLD_STRICTNESS +module Demand () where +#else + +module Demand( + Demand(..), + + wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum, + isStrict, isLazy, isPrim, + + pprDemands, seqDemand, seqDemands, + + StrictnessInfo(..), + mkStrictnessInfo, + noStrictnessInfo, + ppStrictnessInfo, seqStrictnessInfo, + isBottomingStrictness, appIsBottom, + + ) where + +#include "HsVersions.h" + +import Outputable +import Util ( listLengthCmp ) +\end{code} + + +%************************************************************************ +%* * +\subsection{The @Demand@ data type} +%* * +%************************************************************************ + +\begin{code} +data Demand + = WwLazy -- Argument is lazy as far as we know + MaybeAbsent -- (does not imply worker's existence [etc]). + -- If MaybeAbsent == True, then it is + -- *definitely* lazy. (NB: Absence implies + -- a worker...) + + | WwStrict -- Argument is strict but that's all we know + -- (does not imply worker's existence or any + -- calling-convention magic) + + | WwUnpack -- Argument is strict & a single-constructor type + Bool -- True <=> wrapper unpacks it; False <=> doesn't + [Demand] -- Its constituent parts (whose StrictInfos + -- are in the list) should be passed + -- as arguments to the worker. + + | WwPrim -- Argument is of primitive type, therefore + -- strict; doesn't imply existence of a worker; + -- argument should be passed as is to worker. + + | WwEnum -- Argument is strict & an enumeration type; + -- an Int# representing the tag (start counting + -- at zero) should be passed to the worker. + deriving( Eq ) + +type MaybeAbsent = Bool -- True <=> not even used + +-- versions that don't worry about Absence: +wwLazy = WwLazy False +wwStrict = WwStrict +wwUnpack xs = WwUnpack False xs +wwPrim = WwPrim +wwEnum = WwEnum + +seqDemand :: Demand -> () +seqDemand (WwLazy a) = a `seq` () +seqDemand (WwUnpack b ds) = b `seq` seqDemands ds +seqDemand other = () + +seqDemands [] = () +seqDemands (d:ds) = seqDemand d `seq` seqDemands ds +\end{code} + + +%************************************************************************ +%* * +\subsection{Functions over @Demand@} +%* * +%************************************************************************ + +\begin{code} +isLazy :: Demand -> Bool +isLazy (WwLazy _) = True +isLazy _ = False + +isStrict :: Demand -> Bool +isStrict d = not (isLazy d) + +isPrim :: Demand -> Bool +isPrim WwPrim = True +isPrim other = False +\end{code} + + +%************************************************************************ +%* * +\subsection{Instances} +%* * +%************************************************************************ + + +\begin{code} +pprDemands demands bot = hcat (map pprDemand demands) <> pp_bot + where + pp_bot | bot = ptext SLIT("B") + | otherwise = empty + + +pprDemand (WwLazy False) = char 'L' +pprDemand (WwLazy True) = char 'A' +pprDemand WwStrict = char 'S' +pprDemand WwPrim = char 'P' +pprDemand WwEnum = char 'E' +pprDemand (WwUnpack wu args) = char ch <> parens (hcat (map pprDemand args)) + where + ch = if wu then 'U' else 'u' + +instance Outputable Demand where + ppr (WwLazy False) = empty + ppr other_demand = ptext SLIT("__D") <+> pprDemand other_demand + +instance Show Demand where + showsPrec p d = showsPrecSDoc p (ppr d) + +-- Reading demands is done in Lex.lhs +\end{code} + + +%************************************************************************ +%* * +\subsection[strictness-IdInfo]{Strictness info about an @Id@} +%* * +%************************************************************************ + +We specify the strictness of a function by giving information about +each of the ``wrapper's'' arguments (see the description about +worker/wrapper-style transformations in the PJ/Launchbury paper on +unboxed types). + +The list of @Demands@ specifies: (a)~the strictness properties of a +function's arguments; and (b)~the type signature of that worker (if it +exists); i.e. its calling convention. + +Note that the existence of a worker function is now denoted by the Id's +workerInfo field. + +\begin{code} +data StrictnessInfo + = NoStrictnessInfo + + | StrictnessInfo [Demand] -- Demands on the arguments. + + Bool -- True <=> the function diverges regardless of its arguments + -- Useful for "error" and other disguised variants thereof. + -- BUT NB: f = \x y. error "urk" + -- will have info SI [SS] True + -- but still (f) and (f 2) are not bot; only (f 3 2) is bot + deriving( Eq ) + + -- NOTA BENE: if the arg demands are, say, [S,L], this means that + -- (f bot) is not necy bot, only (f bot x) is bot + -- We simply cannot express accurately the strictness of a function + -- like f = \x -> case x of (a,b) -> \y -> ... + -- The up-side is that we don't need to restrict the strictness info + -- to the visible arity of the function. + +seqStrictnessInfo :: StrictnessInfo -> () +seqStrictnessInfo (StrictnessInfo ds b) = b `seq` seqDemands ds +seqStrictnessInfo other = () +\end{code} + +\begin{code} +mkStrictnessInfo :: ([Demand], Bool) -> StrictnessInfo + +mkStrictnessInfo (xs, is_bot) + | all totally_boring xs && not is_bot = NoStrictnessInfo -- Uninteresting + | otherwise = StrictnessInfo xs is_bot + where + totally_boring (WwLazy False) = True + totally_boring other = False + +noStrictnessInfo = NoStrictnessInfo + +isBottomingStrictness (StrictnessInfo _ bot) = bot +isBottomingStrictness NoStrictnessInfo = False + +-- appIsBottom returns true if an application to n args would diverge +appIsBottom (StrictnessInfo ds bot) n = bot && (listLengthCmp ds n /=GT) -- not more than 'n' elts in 'ds'. +appIsBottom NoStrictnessInfo n = False + +ppStrictnessInfo NoStrictnessInfo = empty +ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_args bot] +\end{code} + +\begin{code} +#endif /* OLD_STRICTNESS */ +\end{code} diff --git a/compiler/basicTypes/FieldLabel.lhs b/compiler/basicTypes/FieldLabel.lhs new file mode 100644 index 0000000000..b388d378d7 --- /dev/null +++ b/compiler/basicTypes/FieldLabel.lhs @@ -0,0 +1,71 @@ +% +% (c) The AQUA Project, Glasgow University, 1996-1998 +% +\section[FieldLabel]{The @FieldLabel@ type} + +\begin{code} +module FieldLabel( + FieldLabel, -- Abstract + + mkFieldLabel, + fieldLabelName, fieldLabelTyCon, fieldLabelType, fieldLabelTag, + + FieldLabelTag, + firstFieldLabelTag, allFieldLabelTags + ) where + +#include "HsVersions.h" + +import Type( Type ) +import TyCon( TyCon ) +import Name ( Name{-instance Eq/Outputable-}, NamedThing(..), nameUnique ) +import Outputable +import Unique ( Uniquable(..) ) +\end{code} + +\begin{code} +data FieldLabel + = FieldLabel Name -- Also used as the Name of the field selector Id + + TyCon -- Parent type constructor + + Type -- Type of the field; may have free type variables that + -- are the tyvars of its parent *data* constructor, and + -- those will be the same as the tyvars of its parent *type* constructor + -- e.g. data T a = MkT { op1 :: a -> a, op2 :: a -> Int } + -- The type in the FieldLabel for op1 will be simply (a->a). + + FieldLabelTag -- Indicates position within constructor + -- (starting with firstFieldLabelTag) + -- + -- If the same field occurs in more than one constructor + -- then it'll have a separate FieldLabel on each occasion, + -- but with a single name (and presumably the same type!) + +type FieldLabelTag = Int + +mkFieldLabel = FieldLabel + +firstFieldLabelTag :: FieldLabelTag +firstFieldLabelTag = 1 + +allFieldLabelTags :: [FieldLabelTag] +allFieldLabelTags = [firstFieldLabelTag..] + +fieldLabelName (FieldLabel n _ _ _) = n +fieldLabelTyCon (FieldLabel _ tc _ _) = tc +fieldLabelType (FieldLabel _ _ ty _) = ty +fieldLabelTag (FieldLabel _ _ _ tag) = tag + +instance Eq FieldLabel where + fl1 == fl2 = fieldLabelName fl1 == fieldLabelName fl2 + +instance Outputable FieldLabel where + ppr fl = ppr (fieldLabelName fl) + +instance NamedThing FieldLabel where + getName = fieldLabelName + +instance Uniquable FieldLabel where + getUnique fl = nameUnique (fieldLabelName fl) +\end{code} diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs new file mode 100644 index 0000000000..c7ce818adb --- /dev/null +++ b/compiler/basicTypes/Id.lhs @@ -0,0 +1,529 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[Id]{@Ids@: Value and constructor identifiers} + +\begin{code} +module Id ( + Id, DictId, + + -- Simple construction + mkGlobalId, mkLocalId, mkLocalIdWithInfo, + mkSysLocal, mkUserLocal, mkVanillaGlobal, + mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, + mkWorkerId, mkExportedLocalId, + + -- Taking an Id apart + idName, idType, idUnique, idInfo, + isId, globalIdDetails, idPrimRep, + recordSelectorFieldLabel, + + -- Modifying an Id + setIdName, setIdUnique, Id.setIdType, setIdExported, setIdNotExported, + setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, + zapLamIdInfo, zapDemandIdInfo, + + -- Predicates + isImplicitId, isDeadBinder, isDictId, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, isNaughtyRecordSelector, + isClassOpId_maybe, + isPrimOpId, isPrimOpId_maybe, + isFCallId, isFCallId_maybe, + isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon, + isBottomingId, idIsFrom, + hasNoBinding, + + -- Inline pragma stuff + idInlinePragma, setInlinePragma, modifyInlinePragma, + + + -- One shot lambda stuff + isOneShotBndr, isOneShotLambda, isStateHackType, + setOneShotLambda, clearOneShotLambda, + + -- IdInfo stuff + setIdUnfolding, + setIdArity, + setIdNewDemandInfo, + setIdNewStrictness, zapIdNewStrictness, + setIdWorkerInfo, + setIdSpecialisation, + setIdCafInfo, + setIdOccInfo, + +#ifdef OLD_STRICTNESS + idDemandInfo, + idStrictness, + idCprInfo, + setIdStrictness, + setIdDemandInfo, + setIdCprInfo, +#endif + + idArity, + idNewDemandInfo, idNewDemandInfo_maybe, + idNewStrictness, idNewStrictness_maybe, + idWorkerInfo, + idUnfolding, + idSpecialisation, idCoreRules, + idCafInfo, + idLBVarInfo, + idOccInfo, + +#ifdef OLD_STRICTNESS + newStrictnessFromOld -- Temporary +#endif + + ) where + +#include "HsVersions.h" + + +import CoreSyn ( Unfolding, CoreRule ) +import BasicTypes ( Arity ) +import Var ( Id, DictId, + isId, isExportedId, isLocalId, + idName, idType, idUnique, idInfo, isGlobalId, + setIdName, setIdType, setIdUnique, + setIdExported, setIdNotExported, + setIdInfo, lazySetIdInfo, modifyIdInfo, + maybeModifyIdInfo, + globalIdDetails + ) +import qualified Var ( mkLocalId, mkGlobalId, mkExportedLocalId ) +import TyCon ( FieldLabel, TyCon ) +import Type ( Type, typePrimRep, addFreeTyVars, seqType, + splitTyConApp_maybe, PrimRep ) +import TcType ( isDictTy ) +import TysPrim ( statePrimTyCon ) +import IdInfo + +#ifdef OLD_STRICTNESS +import qualified Demand ( Demand ) +#endif +import DataCon ( DataCon, isUnboxedTupleCon ) +import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig ) +import Name ( Name, OccName, nameIsLocalOrFrom, + mkSystemVarName, mkInternalName, getOccName, + getSrcLoc ) +import Module ( Module ) +import OccName ( mkWorkerOcc ) +import Maybes ( orElse ) +import SrcLoc ( SrcLoc ) +import Outputable +import Unique ( Unique, mkBuiltinUnique ) +import FastString ( FastString ) +import StaticFlags ( opt_NoStateHack ) + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setIdUnfolding`, + `setIdArity`, + `setIdNewDemandInfo`, + `setIdNewStrictness`, + `setIdWorkerInfo`, + `setIdSpecialisation`, + `setInlinePragma`, + `idCafInfo` +#ifdef OLD_STRICTNESS + ,`idCprInfo` + ,`setIdStrictness` + ,`setIdDemandInfo` +#endif +\end{code} + + + +%************************************************************************ +%* * +\subsection{Simple Id construction} +%* * +%************************************************************************ + +Absolutely all Ids are made by mkId. It is just like Var.mkId, +but in addition it pins free-tyvar-info onto the Id's type, +where it can easily be found. + +\begin{code} +mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id +mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info + +mkExportedLocalId :: Name -> Type -> Id +mkExportedLocalId name ty = Var.mkExportedLocalId name (addFreeTyVars ty) vanillaIdInfo + +mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info +\end{code} + +\begin{code} +mkLocalId :: Name -> Type -> Id +mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo + +-- SysLocal: for an Id being created by the compiler out of thin air... +-- UserLocal: an Id with a name the user might recognize... +mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> Id +mkSysLocal :: FastString -> Unique -> Type -> Id +mkVanillaGlobal :: Name -> Type -> IdInfo -> Id + +mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty + +mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty +mkVanillaGlobal = mkGlobalId VanillaGlobal +\end{code} + +Make some local @Ids@ for a template @CoreExpr@. These have bogus +@Uniques@, but that's OK because the templates are supposed to be +instantiated before use. + +\begin{code} +-- "Wild Id" typically used when you need a binder that you don't expect to use +mkWildId :: Type -> Id +mkWildId ty = mkSysLocal FSLIT("wild") (mkBuiltinUnique 1) ty + +mkWorkerId :: Unique -> Id -> Type -> Id +-- A worker gets a local name. CoreTidy will externalise it if necessary. +mkWorkerId uniq unwrkr ty + = mkLocalId wkr_name ty + where + wkr_name = mkInternalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr) + +-- "Template locals" typically used in unfoldings +mkTemplateLocals :: [Type] -> [Id] +mkTemplateLocals tys = zipWith mkTemplateLocal [1..] tys + +mkTemplateLocalsNum :: Int -> [Type] -> [Id] +-- The Int gives the starting point for unique allocation +mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys + +mkTemplateLocal :: Int -> Type -> Id +mkTemplateLocal i ty = mkSysLocal FSLIT("tpl") (mkBuiltinUnique i) ty +\end{code} + + +%************************************************************************ +%* * +\subsection[Id-general-funs]{General @Id@-related functions} +%* * +%************************************************************************ + +\begin{code} +setIdType :: Id -> Type -> Id + -- Add free tyvar info to the type +setIdType id ty = seqType ty `seq` Var.setIdType id (addFreeTyVars ty) + +idPrimRep :: Id -> PrimRep +idPrimRep id = typePrimRep (idType id) +\end{code} + + +%************************************************************************ +%* * +\subsection{Special Ids} +%* * +%************************************************************************ + +\begin{code} +recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel) +recordSelectorFieldLabel id = case globalIdDetails id of + RecordSelId tycon lbl _ -> (tycon,lbl) + other -> panic "recordSelectorFieldLabel" + +isRecordSelector id = case globalIdDetails id of + RecordSelId {} -> True + other -> False + +isNaughtyRecordSelector id = case globalIdDetails id of + RecordSelId { sel_naughty = n } -> n + other -> False + +isClassOpId_maybe id = case globalIdDetails id of + ClassOpId cls -> Just cls + _other -> Nothing + +isPrimOpId id = case globalIdDetails id of + PrimOpId op -> True + other -> False + +isPrimOpId_maybe id = case globalIdDetails id of + PrimOpId op -> Just op + other -> Nothing + +isFCallId id = case globalIdDetails id of + FCallId call -> True + other -> False + +isFCallId_maybe id = case globalIdDetails id of + FCallId call -> Just call + other -> Nothing + +isDataConWorkId id = case globalIdDetails id of + DataConWorkId _ -> True + other -> False + +isDataConWorkId_maybe id = case globalIdDetails id of + DataConWorkId con -> Just con + other -> Nothing + +isDataConId_maybe :: Id -> Maybe DataCon +isDataConId_maybe id = case globalIdDetails id of + DataConWorkId con -> Just con + DataConWrapId con -> Just con + other -> Nothing + +idDataCon :: Id -> DataCon +-- Get from either the worker or the wrapper to the DataCon +-- Currently used only in the desugarer +-- INVARIANT: idDataCon (dataConWrapId d) = d +-- (Remember, dataConWrapId can return either the wrapper or the worker.) +idDataCon id = case globalIdDetails id of + DataConWorkId con -> con + DataConWrapId con -> con + other -> pprPanic "idDataCon" (ppr id) + + +isDictId :: Id -> Bool +isDictId id = isDictTy (idType id) + +-- hasNoBinding returns True of an Id which may not have a +-- binding, even though it is defined in this module. +-- Data constructor workers used to be things of this kind, but +-- they aren't any more. Instead, we inject a binding for +-- them at the CorePrep stage. +-- EXCEPT: unboxed tuples, which definitely have no binding +hasNoBinding id = case globalIdDetails id of + PrimOpId _ -> True + FCallId _ -> True + DataConWorkId dc -> isUnboxedTupleCon dc + other -> False + +isImplicitId :: Id -> Bool + -- isImplicitId tells whether an Id's info is implied by other + -- declarations, so we don't need to put its signature in an interface + -- file, even if it's mentioned in some other interface unfolding. +isImplicitId id + = case globalIdDetails id of + RecordSelId {} -> True + FCallId _ -> True + PrimOpId _ -> True + ClassOpId _ -> True + DataConWorkId _ -> True + DataConWrapId _ -> True + -- These are are implied by their type or class decl; + -- remember that all type and class decls appear in the interface file. + -- The dfun id is not an implicit Id; it must *not* be omitted, because + -- it carries version info for the instance decl + other -> False + +idIsFrom :: Module -> Id -> Bool +idIsFrom mod id = nameIsLocalOrFrom mod (idName id) +\end{code} + +\begin{code} +isDeadBinder :: Id -> Bool +isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) + | otherwise = False -- TyVars count as not dead +\end{code} + + +%************************************************************************ +%* * +\subsection{IdInfo stuff} +%* * +%************************************************************************ + +\begin{code} + --------------------------------- + -- ARITY +idArity :: Id -> Arity +idArity id = arityInfo (idInfo id) + +setIdArity :: Id -> Arity -> Id +setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id + +#ifdef OLD_STRICTNESS + --------------------------------- + -- (OLD) STRICTNESS +idStrictness :: Id -> StrictnessInfo +idStrictness id = strictnessInfo (idInfo id) + +setIdStrictness :: Id -> StrictnessInfo -> Id +setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id +#endif + +-- isBottomingId returns true if an application to n args would diverge +isBottomingId :: Id -> Bool +isBottomingId id = isBottomingSig (idNewStrictness id) + +idNewStrictness_maybe :: Id -> Maybe StrictSig +idNewStrictness :: Id -> StrictSig + +idNewStrictness_maybe id = newStrictnessInfo (idInfo id) +idNewStrictness id = idNewStrictness_maybe id `orElse` topSig + +setIdNewStrictness :: Id -> StrictSig -> Id +setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id + +zapIdNewStrictness :: Id -> Id +zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id + + --------------------------------- + -- WORKER ID +idWorkerInfo :: Id -> WorkerInfo +idWorkerInfo id = workerInfo (idInfo id) + +setIdWorkerInfo :: Id -> WorkerInfo -> Id +setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id + + --------------------------------- + -- UNFOLDING +idUnfolding :: Id -> Unfolding +idUnfolding id = unfoldingInfo (idInfo id) + +setIdUnfolding :: Id -> Unfolding -> Id +setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id + +#ifdef OLD_STRICTNESS + --------------------------------- + -- (OLD) DEMAND +idDemandInfo :: Id -> Demand.Demand +idDemandInfo id = demandInfo (idInfo id) + +setIdDemandInfo :: Id -> Demand.Demand -> Id +setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id +#endif + +idNewDemandInfo_maybe :: Id -> Maybe NewDemand.Demand +idNewDemandInfo :: Id -> NewDemand.Demand + +idNewDemandInfo_maybe id = newDemandInfo (idInfo id) +idNewDemandInfo id = newDemandInfo (idInfo id) `orElse` NewDemand.topDmd + +setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id +setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id + + --------------------------------- + -- SPECIALISATION +idSpecialisation :: Id -> SpecInfo +idSpecialisation id = specInfo (idInfo id) + +idCoreRules :: Id -> [CoreRule] +idCoreRules id = specInfoRules (idSpecialisation id) + +setIdSpecialisation :: Id -> SpecInfo -> Id +setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id + + --------------------------------- + -- CAF INFO +idCafInfo :: Id -> CafInfo +#ifdef OLD_STRICTNESS +idCafInfo id = case cgInfo (idInfo id) of + NoCgInfo -> pprPanic "idCafInfo" (ppr id) + info -> cgCafInfo info +#else +idCafInfo id = cafInfo (idInfo id) +#endif + +setIdCafInfo :: Id -> CafInfo -> Id +setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id + + --------------------------------- + -- CPR INFO +#ifdef OLD_STRICTNESS +idCprInfo :: Id -> CprInfo +idCprInfo id = cprInfo (idInfo id) + +setIdCprInfo :: Id -> CprInfo -> Id +setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id +#endif + + --------------------------------- + -- Occcurrence INFO +idOccInfo :: Id -> OccInfo +idOccInfo id = occInfo (idInfo id) + +setIdOccInfo :: Id -> OccInfo -> Id +setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id +\end{code} + + + --------------------------------- + -- INLINING +The inline pragma tells us to be very keen to inline this Id, but it's still +OK not to if optimisation is switched off. + +\begin{code} +idInlinePragma :: Id -> InlinePragInfo +idInlinePragma id = inlinePragInfo (idInfo id) + +setInlinePragma :: Id -> InlinePragInfo -> Id +setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id + +modifyInlinePragma :: Id -> (InlinePragInfo -> InlinePragInfo) -> Id +modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id +\end{code} + + + --------------------------------- + -- ONE-SHOT LAMBDAS +\begin{code} +idLBVarInfo :: Id -> LBVarInfo +idLBVarInfo id = lbvarInfo (idInfo id) + +isOneShotBndr :: Id -> Bool +-- This one is the "business end", called externally. +-- Its main purpose is to encapsulate the Horrible State Hack +isOneShotBndr id = isOneShotLambda id || (isStateHackType (idType id)) + +isStateHackType :: Type -> Bool +isStateHackType ty + | opt_NoStateHack + = False + | otherwise + = case splitTyConApp_maybe ty of + Just (tycon,_) -> tycon == statePrimTyCon + other -> False + -- This is a gross hack. It claims that + -- every function over realWorldStatePrimTy is a one-shot + -- function. This is pretty true in practice, and makes a big + -- difference. For example, consider + -- a `thenST` \ r -> ...E... + -- The early full laziness pass, if it doesn't know that r is one-shot + -- will pull out E (let's say it doesn't mention r) to give + -- let lvl = E in a `thenST` \ r -> ...lvl... + -- When `thenST` gets inlined, we end up with + -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... + -- and we don't re-inline E. + -- + -- It would be better to spot that r was one-shot to start with, but + -- I don't want to rely on that. + -- + -- Another good example is in fill_in in PrelPack.lhs. We should be able to + -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. + + +-- The OneShotLambda functions simply fiddle with the IdInfo flag +isOneShotLambda :: Id -> Bool +isOneShotLambda id = case idLBVarInfo id of + IsOneShotLambda -> True + NoLBVarInfo -> False + +setOneShotLambda :: Id -> Id +setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id + +clearOneShotLambda :: Id -> Id +clearOneShotLambda id + | isOneShotLambda id = modifyIdInfo (`setLBVarInfo` NoLBVarInfo) id + | otherwise = id + +-- But watch out: this may change the type of something else +-- f = \x -> e +-- If we change the one-shot-ness of x, f's type changes +\end{code} + +\begin{code} +zapLamIdInfo :: Id -> Id +zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id + +zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id +\end{code} + diff --git a/compiler/basicTypes/IdInfo.hi-boot-5 b/compiler/basicTypes/IdInfo.hi-boot-5 new file mode 100644 index 0000000000..4a326cad6f --- /dev/null +++ b/compiler/basicTypes/IdInfo.hi-boot-5 @@ -0,0 +1,8 @@ +__interface IdInfo 1 0 where +__export IdInfo IdInfo GlobalIdDetails notGlobalId seqIdInfo vanillaIdInfo ; +1 data IdInfo ; +1 data GlobalIdDetails ; +1 notGlobalId :: GlobalIdDetails ; +1 seqIdInfo :: IdInfo -> PrelBase.Z0T ; +1 vanillaIdInfo :: IdInfo ; + diff --git a/compiler/basicTypes/IdInfo.hi-boot-6 b/compiler/basicTypes/IdInfo.hi-boot-6 new file mode 100644 index 0000000000..e090800d61 --- /dev/null +++ b/compiler/basicTypes/IdInfo.hi-boot-6 @@ -0,0 +1,8 @@ +module IdInfo where + +data IdInfo +data GlobalIdDetails + +notGlobalId :: GlobalIdDetails +seqIdInfo :: IdInfo -> () +vanillaIdInfo :: IdInfo diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs new file mode 100644 index 0000000000..d53bf5627d --- /dev/null +++ b/compiler/basicTypes/IdInfo.lhs @@ -0,0 +1,699 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} + +(And a pretty good illustration of quite a few things wrong with +Haskell. [WDP 94/11]) + +\begin{code} +module IdInfo ( + GlobalIdDetails(..), notGlobalId, -- Not abstract + + IdInfo, -- Abstract + vanillaIdInfo, noCafIdInfo, + seqIdInfo, megaSeqIdInfo, + + -- Zapping + zapLamInfo, zapDemandInfo, + + -- Arity + ArityInfo, + unknownArity, + arityInfo, setArityInfo, ppArityInfo, + + -- New demand and strictness info + newStrictnessInfo, setNewStrictnessInfo, + newDemandInfo, setNewDemandInfo, pprNewStrictness, + setAllStrictnessInfo, + +#ifdef OLD_STRICTNESS + -- Strictness; imported from Demand + StrictnessInfo(..), + mkStrictnessInfo, noStrictnessInfo, + ppStrictnessInfo,isBottomingStrictness, +#endif + + -- Worker + WorkerInfo(..), workerExists, wrapperArity, workerId, + workerInfo, setWorkerInfo, ppWorkerInfo, + + -- Unfolding + unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily, + +#ifdef OLD_STRICTNESS + -- Old DemandInfo and StrictnessInfo + demandInfo, setDemandInfo, + strictnessInfo, setStrictnessInfo, + cprInfoFromNewStrictness, + oldStrictnessFromNew, newStrictnessFromOld, + oldDemand, newDemand, + + -- Constructed Product Result Info + CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo, +#endif + + -- Inline prags + InlinePragInfo, + inlinePragInfo, setInlinePragInfo, + + -- Occurrence info + OccInfo(..), isFragileOcc, isDeadOcc, isLoopBreaker, + InsideLam, OneBranch, insideLam, notInsideLam, oneBranch, notOneBranch, + occInfo, setOccInfo, + + -- Specialisation + SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, + specInfoFreeVars, specInfoRules, seqSpecInfo, + + -- CAF info + CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs, + + -- Lambda-bound variable info + LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo + ) where + +#include "HsVersions.h" + + +import CoreSyn +import Class ( Class ) +import PrimOp ( PrimOp ) +import Var ( Id ) +import VarSet ( VarSet, emptyVarSet, seqVarSet ) +import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker, + InsideLam, insideLam, notInsideLam, + OneBranch, oneBranch, notOneBranch, + Arity, + Activation(..) + ) +import DataCon ( DataCon ) +import TyCon ( TyCon, FieldLabel ) +import ForeignCall ( ForeignCall ) +import NewDemand +import Outputable +import Maybe ( isJust ) + +#ifdef OLD_STRICTNESS +import Name ( Name ) +import Demand hiding( Demand, seqDemand ) +import qualified Demand +import Util ( listLengthCmp ) +import List ( replicate ) +#endif + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setSpecInfo`, + `setArityInfo`, + `setInlinePragInfo`, + `setUnfoldingInfo`, + `setWorkerInfo`, + `setLBVarInfo`, + `setOccInfo`, + `setCafInfo`, + `setNewStrictnessInfo`, + `setAllStrictnessInfo`, + `setNewDemandInfo` +#ifdef OLD_STRICTNESS + , `setCprInfo` + , `setDemandInfo` + , `setStrictnessInfo` +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{New strictness info} +%* * +%************************************************************************ + +To be removed later + +\begin{code} +-- setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo +-- Set old and new strictness info +setAllStrictnessInfo info Nothing + = info { newStrictnessInfo = Nothing +#ifdef OLD_STRICTNESS + , strictnessInfo = NoStrictnessInfo + , cprInfo = NoCPRInfo +#endif + } + +setAllStrictnessInfo info (Just sig) + = info { newStrictnessInfo = Just sig +#ifdef OLD_STRICTNESS + , strictnessInfo = oldStrictnessFromNew sig + , cprInfo = cprInfoFromNewStrictness sig +#endif + } + +seqNewStrictnessInfo Nothing = () +seqNewStrictnessInfo (Just ty) = seqStrictSig ty + +pprNewStrictness Nothing = empty +pprNewStrictness (Just sig) = ftext FSLIT("Str:") <+> ppr sig + +#ifdef OLD_STRICTNESS +oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo +oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info) + where + (dmds, res_info) = splitStrictSig sig + +cprInfoFromNewStrictness :: StrictSig -> CprInfo +cprInfoFromNewStrictness sig = case strictSigResInfo sig of + RetCPR -> ReturnsCPR + other -> NoCPRInfo + +newStrictnessFromOld :: Name -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig +newStrictnessFromOld name arity (Demand.StrictnessInfo ds res) cpr + | listLengthCmp ds arity /= GT -- length ds <= arity + -- Sometimes the old strictness analyser has more + -- demands than the arity justifies + = mk_strict_sig name arity $ + mkTopDmdType (map newDemand ds) (newRes res cpr) + +newStrictnessFromOld name arity other cpr + = -- Either no strictness info, or arity is too small + -- In either case we can't say anything useful + mk_strict_sig name arity $ + mkTopDmdType (replicate arity lazyDmd) (newRes False cpr) + +mk_strict_sig name arity dmd_ty + = WARN( arity /= dmdTypeDepth dmd_ty, ppr name <+> (ppr arity $$ ppr dmd_ty) ) + mkStrictSig dmd_ty + +newRes True _ = BotRes +newRes False ReturnsCPR = retCPR +newRes False NoCPRInfo = TopRes + +newDemand :: Demand.Demand -> NewDemand.Demand +newDemand (WwLazy True) = Abs +newDemand (WwLazy False) = lazyDmd +newDemand WwStrict = evalDmd +newDemand (WwUnpack unpk ds) = Eval (Prod (map newDemand ds)) +newDemand WwPrim = lazyDmd +newDemand WwEnum = evalDmd + +oldDemand :: NewDemand.Demand -> Demand.Demand +oldDemand Abs = WwLazy True +oldDemand Top = WwLazy False +oldDemand Bot = WwStrict +oldDemand (Box Bot) = WwStrict +oldDemand (Box Abs) = WwLazy False +oldDemand (Box (Eval _)) = WwStrict -- Pass box only +oldDemand (Defer d) = WwLazy False +oldDemand (Eval (Prod ds)) = WwUnpack True (map oldDemand ds) +oldDemand (Eval (Poly _)) = WwStrict +oldDemand (Call _) = WwStrict + +#endif /* OLD_STRICTNESS */ +\end{code} + + +\begin{code} +seqNewDemandInfo Nothing = () +seqNewDemandInfo (Just dmd) = seqDemand dmd +\end{code} + + +%************************************************************************ +%* * +\subsection{GlobalIdDetails +%* * +%************************************************************************ + +This type is here (rather than in Id.lhs) mainly because there's +an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported +(recursively) by Var.lhs. + +\begin{code} +data GlobalIdDetails + = VanillaGlobal -- Imported from elsewhere, a default method Id. + + | RecordSelId -- The Id for a record selector + { sel_tycon :: TyCon + , sel_label :: FieldLabel + , sel_naughty :: Bool -- True <=> naughty + } -- See Note [Naughty record selectors] + -- with MkId.mkRecordSelectorId + + | DataConWorkId DataCon -- The Id for a data constructor *worker* + | DataConWrapId DataCon -- The Id for a data constructor *wrapper* + -- [the only reasons we need to know is so that + -- a) to support isImplicitId + -- b) when desugaring a RecordCon we can get + -- from the Id back to the data con] + + | ClassOpId Class -- An operation of a class + + | PrimOpId PrimOp -- The Id for a primitive operator + | FCallId ForeignCall -- The Id for a foreign call + + | NotGlobalId -- Used as a convenient extra return value from globalIdDetails + +notGlobalId = NotGlobalId + +instance Outputable GlobalIdDetails where + ppr NotGlobalId = ptext SLIT("[***NotGlobalId***]") + ppr VanillaGlobal = ptext SLIT("[GlobalId]") + ppr (DataConWorkId _) = ptext SLIT("[DataCon]") + ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]") + ppr (ClassOpId _) = ptext SLIT("[ClassOp]") + ppr (PrimOpId _) = ptext SLIT("[PrimOp]") + ppr (FCallId _) = ptext SLIT("[ForeignCall]") + ppr (RecordSelId {}) = ptext SLIT("[RecSel]") +\end{code} + + +%************************************************************************ +%* * +\subsection{The main IdInfo type} +%* * +%************************************************************************ + +An @IdInfo@ gives {\em optional} information about an @Id@. If +present it never lies, but it may not be present, in which case there +is always a conservative assumption which can be made. + +Two @Id@s may have different info even though they have the same +@Unique@ (and are hence the same @Id@); for example, one might lack +the properties attached to the other. + +The @IdInfo@ gives information about the value, or definition, of the +@Id@. It does {\em not} contain information about the @Id@'s usage +(except for @DemandInfo@? ToDo). (@lbvarInfo@ is also a marginal +case. KSW 1999-04). + +\begin{code} +data IdInfo + = IdInfo { + arityInfo :: !ArityInfo, -- Its arity + specInfo :: SpecInfo, -- Specialisations of this function which exist +#ifdef OLD_STRICTNESS + cprInfo :: CprInfo, -- Function always constructs a product result + demandInfo :: Demand.Demand, -- Whether or not it is definitely demanded + strictnessInfo :: StrictnessInfo, -- Strictness properties +#endif + workerInfo :: WorkerInfo, -- Pointer to Worker Function + -- Within one module this is irrelevant; the + -- inlining of a worker is handled via the Unfolding + -- WorkerInfo is used *only* to indicate the form of + -- the RHS, so that interface files don't actually + -- need to contain the RHS; it can be derived from + -- the strictness info + + unfoldingInfo :: Unfolding, -- Its unfolding + cafInfo :: CafInfo, -- CAF info + lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable + inlinePragInfo :: InlinePragInfo, -- Inline pragma + occInfo :: OccInfo, -- How it occurs + + newStrictnessInfo :: Maybe StrictSig, -- Reason for Maybe: the DmdAnal phase needs to + -- know whether whether this is the first visit, + -- so it can assign botSig. Other customers want + -- topSig. So Nothing is good. + + newDemandInfo :: Maybe Demand -- Similarly we want to know if there's no + -- known demand yet, for when we are looking for + -- CPR info + } + +seqIdInfo :: IdInfo -> () +seqIdInfo (IdInfo {}) = () + +megaSeqIdInfo :: IdInfo -> () +megaSeqIdInfo info + = seqSpecInfo (specInfo info) `seq` + seqWorker (workerInfo info) `seq` + +-- Omitting this improves runtimes a little, presumably because +-- some unfoldings are not calculated at all +-- seqUnfolding (unfoldingInfo info) `seq` + + seqNewDemandInfo (newDemandInfo info) `seq` + seqNewStrictnessInfo (newStrictnessInfo info) `seq` + +#ifdef OLD_STRICTNESS + Demand.seqDemand (demandInfo info) `seq` + seqStrictnessInfo (strictnessInfo info) `seq` + seqCpr (cprInfo info) `seq` +#endif + + seqCaf (cafInfo info) `seq` + seqLBVar (lbvarInfo info) `seq` + seqOccInfo (occInfo info) +\end{code} + +Setters + +\begin{code} +setWorkerInfo info wk = wk `seq` info { workerInfo = wk } +setSpecInfo info sp = sp `seq` info { specInfo = sp } +setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } +setOccInfo info oc = oc `seq` info { occInfo = oc } +#ifdef OLD_STRICTNESS +setStrictnessInfo info st = st `seq` info { strictnessInfo = st } +#endif + -- Try to avoid spack leaks by seq'ing + +setUnfoldingInfoLazily info uf -- Lazy variant to avoid looking at the + = -- unfolding of an imported Id unless necessary + info { unfoldingInfo = uf } -- (In this case the demand-zapping is redundant.) + +setUnfoldingInfo info uf + -- We do *not* seq on the unfolding info, For some reason, doing so + -- actually increases residency significantly. + = info { unfoldingInfo = uf } + +#ifdef OLD_STRICTNESS +setDemandInfo info dd = info { demandInfo = dd } +setCprInfo info cp = info { cprInfo = cp } +#endif + +setArityInfo info ar = info { arityInfo = ar } +setCafInfo info caf = info { cafInfo = caf } + +setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb } + +setNewDemandInfo info dd = dd `seq` info { newDemandInfo = dd } +setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd } +\end{code} + + +\begin{code} +vanillaIdInfo :: IdInfo +vanillaIdInfo + = IdInfo { + cafInfo = vanillaCafInfo, + arityInfo = unknownArity, +#ifdef OLD_STRICTNESS + cprInfo = NoCPRInfo, + demandInfo = wwLazy, + strictnessInfo = NoStrictnessInfo, +#endif + specInfo = emptySpecInfo, + workerInfo = NoWorker, + unfoldingInfo = noUnfolding, + lbvarInfo = NoLBVarInfo, + inlinePragInfo = AlwaysActive, + occInfo = NoOccInfo, + newDemandInfo = Nothing, + newStrictnessInfo = Nothing + } + +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs + -- Used for built-in type Ids in MkId. +\end{code} + + +%************************************************************************ +%* * +\subsection[arity-IdInfo]{Arity info about an @Id@} +%* * +%************************************************************************ + +For locally-defined Ids, the code generator maintains its own notion +of their arities; so it should not be asking... (but other things +besides the code-generator need arity info!) + +\begin{code} +type ArityInfo = Arity + -- A partial application of this Id to up to n-1 value arguments + -- does essentially no work. That is not necessarily the + -- same as saying that it has n leading lambdas, because coerces + -- may get in the way. + + -- The arity might increase later in the compilation process, if + -- an extra lambda floats up to the binding site. + +unknownArity = 0 :: Arity + +ppArityInfo 0 = empty +ppArityInfo n = hsep [ptext SLIT("Arity"), int n] +\end{code} + +%************************************************************************ +%* * +\subsection{Inline-pragma information} +%* * +%************************************************************************ + +\begin{code} +type InlinePragInfo = Activation + -- Tells when the inlining is active + -- When it is active the thing may be inlined, depending on how + -- big it is. + -- + -- If there was an INLINE pragma, then as a separate matter, the + -- RHS will have been made to look small with a CoreSyn Inline Note + + -- The default InlinePragInfo is AlwaysActive, so the info serves + -- entirely as a way to inhibit inlining until we want it +\end{code} + + +%************************************************************************ +%* * + SpecInfo +%* * +%************************************************************************ + +\begin{code} +-- CoreRules is used only in an idSpecialisation (move to IdInfo?) +data SpecInfo + = SpecInfo [CoreRule] VarSet -- Locally-defined free vars of RHSs + +emptySpecInfo :: SpecInfo +emptySpecInfo = SpecInfo [] emptyVarSet + +isEmptySpecInfo :: SpecInfo -> Bool +isEmptySpecInfo (SpecInfo rs _) = null rs + +specInfoFreeVars :: SpecInfo -> VarSet +specInfoFreeVars (SpecInfo _ fvs) = fvs + +specInfoRules :: SpecInfo -> [CoreRule] +specInfoRules (SpecInfo rules _) = rules + +seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs +\end{code} + + +%************************************************************************ +%* * +\subsection[worker-IdInfo]{Worker info about an @Id@} +%* * +%************************************************************************ + +If this Id has a worker then we store a reference to it. Worker +functions are generated by the worker/wrapper pass. This uses +information from strictness analysis. + +There might not be a worker, even for a strict function, because: +(a) the function might be small enough to inline, so no need + for w/w split +(b) the strictness info might be "SSS" or something, so no w/w split. + +Sometimes the arity of a wrapper changes from the original arity from +which it was generated, so we always emit the "original" arity into +the interface file, as part of the worker info. + +How can this happen? Sometimes we get + f = coerce t (\x y -> $wf x y) +at the moment of w/w split; but the eta reducer turns it into + f = coerce t $wf +which is perfectly fine except that the exposed arity so far as +the code generator is concerned (zero) differs from the arity +when we did the split (2). + +All this arises because we use 'arity' to mean "exactly how many +top level lambdas are there" in interface files; but during the +compilation of this module it means "how many things can I apply +this to". + +\begin{code} + +data WorkerInfo = NoWorker + | HasWorker Id Arity + -- The Arity is the arity of the *wrapper* at the moment of the + -- w/w split. See notes above. + +seqWorker :: WorkerInfo -> () +seqWorker (HasWorker id a) = id `seq` a `seq` () +seqWorker NoWorker = () + +ppWorkerInfo NoWorker = empty +ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("Worker") <+> ppr wk_id + +workerExists :: WorkerInfo -> Bool +workerExists NoWorker = False +workerExists (HasWorker _ _) = True + +workerId :: WorkerInfo -> Id +workerId (HasWorker id _) = id + +wrapperArity :: WorkerInfo -> Arity +wrapperArity (HasWorker _ a) = a +\end{code} + + +%************************************************************************ +%* * +\subsection[CG-IdInfo]{Code generator-related information} +%* * +%************************************************************************ + +\begin{code} +-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs). + +data CafInfo + = MayHaveCafRefs -- either: + -- (1) A function or static constructor + -- that refers to one or more CAFs, + -- (2) A real live CAF + + | NoCafRefs -- A function or static constructor + -- that refers to no CAFs. + +vanillaCafInfo = MayHaveCafRefs -- Definitely safe + +mayHaveCafRefs MayHaveCafRefs = True +mayHaveCafRefs _ = False + +seqCaf c = c `seq` () + +ppCafInfo NoCafRefs = ptext SLIT("NoCafRefs") +ppCafInfo MayHaveCafRefs = empty +\end{code} + +%************************************************************************ +%* * +\subsection[cpr-IdInfo]{Constructed Product Result info about an @Id@} +%* * +%************************************************************************ + +If the @Id@ is a function then it may have CPR info. A CPR analysis +phase detects whether: + +\begin{enumerate} +\item +The function's return value has a product type, i.e. an algebraic type +with a single constructor. Examples of such types are tuples and boxed +primitive values. +\item +The function always 'constructs' the value that it is returning. It +must do this on every path through, and it's OK if it calls another +function which constructs the result. +\end{enumerate} + +If this is the case then we store a template which tells us the +function has the CPR property and which components of the result are +also CPRs. + +\begin{code} +#ifdef OLD_STRICTNESS +data CprInfo + = NoCPRInfo + | ReturnsCPR -- Yes, this function returns a constructed product + -- Implicitly, this means "after the function has been applied + -- to all its arguments", so the worker/wrapper builder in + -- WwLib.mkWWcpr checks that that it is indeed saturated before + -- making use of the CPR info + + -- We used to keep nested info about sub-components, but + -- we never used it so I threw it away + +seqCpr :: CprInfo -> () +seqCpr ReturnsCPR = () +seqCpr NoCPRInfo = () + +noCprInfo = NoCPRInfo + +ppCprInfo NoCPRInfo = empty +ppCprInfo ReturnsCPR = ptext SLIT("__M") + +instance Outputable CprInfo where + ppr = ppCprInfo + +instance Show CprInfo where + showsPrec p c = showsPrecSDoc p (ppr c) +#endif +\end{code} + + +%************************************************************************ +%* * +\subsection[lbvar-IdInfo]{Lambda-bound var info about an @Id@} +%* * +%************************************************************************ + +If the @Id@ is a lambda-bound variable then it may have lambda-bound +var info. Sometimes we know whether the lambda binding this var is a +``one-shot'' lambda; that is, whether it is applied at most once. + +This information may be useful in optimisation, as computations may +safely be floated inside such a lambda without risk of duplicating +work. + +\begin{code} +data LBVarInfo = NoLBVarInfo + | IsOneShotLambda -- The lambda is applied at most once). + +seqLBVar l = l `seq` () +\end{code} + +\begin{code} +hasNoLBVarInfo NoLBVarInfo = True +hasNoLBVarInfo IsOneShotLambda = False + +noLBVarInfo = NoLBVarInfo + +pprLBVarInfo NoLBVarInfo = empty +pprLBVarInfo IsOneShotLambda = ptext SLIT("OneShot") + +instance Outputable LBVarInfo where + ppr = pprLBVarInfo + +instance Show LBVarInfo where + showsPrec p c = showsPrecSDoc p (ppr c) +\end{code} + + +%************************************************************************ +%* * +\subsection{Bulk operations on IdInfo} +%* * +%************************************************************************ + +@zapLamInfo@ is used for lambda binders that turn out to to be +part of an unsaturated lambda + +\begin{code} +zapLamInfo :: IdInfo -> Maybe IdInfo +zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand}) + | is_safe_occ occ && is_safe_dmd demand + = Nothing + | otherwise + = Just (info {occInfo = safe_occ, newDemandInfo = Nothing}) + where + -- The "unsafe" occ info is the ones that say I'm not in a lambda + -- because that might not be true for an unsaturated lambda + is_safe_occ (OneOcc in_lam _ _) = in_lam + is_safe_occ other = True + + safe_occ = case occ of + OneOcc _ once int_cxt -> OneOcc insideLam once int_cxt + other -> occ + + is_safe_dmd Nothing = True + is_safe_dmd (Just dmd) = not (isStrictDmd dmd) +\end{code} + +\begin{code} +zapDemandInfo :: IdInfo -> Maybe IdInfo +zapDemandInfo info@(IdInfo {newDemandInfo = dmd}) + | isJust dmd = Just (info {newDemandInfo = Nothing}) + | otherwise = Nothing +\end{code} + diff --git a/compiler/basicTypes/IdInfo.lhs-boot b/compiler/basicTypes/IdInfo.lhs-boot new file mode 100644 index 0000000000..90cf36f90b --- /dev/null +++ b/compiler/basicTypes/IdInfo.lhs-boot @@ -0,0 +1,9 @@ +\begin{code} +module IdInfo where + +data IdInfo +data GlobalIdDetails + +notGlobalId :: GlobalIdDetails +seqIdInfo :: IdInfo -> () +\end{code}
\ No newline at end of file diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs new file mode 100644 index 0000000000..e83ea9db74 --- /dev/null +++ b/compiler/basicTypes/Literal.lhs @@ -0,0 +1,405 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1998 +% +\section[Literal]{@Literal@: Machine literals (unboxed, of course)} + +\begin{code} +module Literal + ( Literal(..) -- Exported to ParseIface + , mkMachInt, mkMachWord + , mkMachInt64, mkMachWord64, mkStringLit + , litSize + , litIsDupable, litIsTrivial + , literalType + , hashLiteral + + , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange + , isZeroLit + + , word2IntLit, int2WordLit + , narrow8IntLit, narrow16IntLit, narrow32IntLit + , narrow8WordLit, narrow16WordLit, narrow32WordLit + , char2IntLit, int2CharLit + , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit + , nullAddrLit, float2DoubleLit, double2FloatLit + ) where + +#include "HsVersions.h" + +import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, + intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy + ) +import Type ( Type ) +import Outputable +import FastTypes +import FastString +import Binary + +import Ratio ( numerator ) +import FastString ( uniqueOfFS, lengthFS ) +import DATA_INT ( Int8, Int16, Int32 ) +import DATA_WORD ( Word8, Word16, Word32 ) +import Char ( ord, chr ) +\end{code} + + + +%************************************************************************ +%* * +\subsection{Sizes} +%* * +%************************************************************************ + +If we're compiling with GHC (and we're not cross-compiling), then we +know that minBound and maxBound :: Int are the right values for the +target architecture. Otherwise, we assume -2^31 and 2^31-1 +respectively (which will be wrong on a 64-bit machine). + +\begin{code} +tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: Integer +#if __GLASGOW_HASKELL__ +tARGET_MIN_INT = toInteger (minBound :: Int) +tARGET_MAX_INT = toInteger (maxBound :: Int) +#else +tARGET_MIN_INT = -2147483648 +tARGET_MAX_INT = 2147483647 +#endif +tARGET_MAX_WORD = (tARGET_MAX_INT * 2) + 1 + +tARGET_MAX_CHAR :: Int +tARGET_MAX_CHAR = 0x10ffff +\end{code} + + +%************************************************************************ +%* * +\subsection{Literals} +%* * +%************************************************************************ + +So-called @Literals@ are {\em either}: +\begin{itemize} +\item +An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.), +which is presumed to be surrounded by appropriate constructors +(@mKINT@, etc.), so that the overall thing makes sense. +\item +An Integer, Rational, or String literal whose representation we are +{\em uncommitted} about; i.e., the surrounding with constructors, +function applications, etc., etc., has not yet been done. +\end{itemize} + +\begin{code} +data Literal + = ------------------ + -- First the primitive guys + MachChar Char -- Char# At least 31 bits + + | MachStr FastString -- A string-literal: stored and emitted + -- UTF-8 encoded, we'll arrange to decode it + -- at runtime. Also emitted with a '\0' + -- terminator. + + | MachNullAddr -- the NULL pointer, the only pointer value + -- that can be represented as a Literal. + + | MachInt Integer -- Int# At least WORD_SIZE_IN_BITS bits + | MachInt64 Integer -- Int64# At least 64 bits + | MachWord Integer -- Word# At least WORD_SIZE_IN_BITS bits + | MachWord64 Integer -- Word64# At least 64 bits + + | MachFloat Rational + | MachDouble Rational + + -- MachLabel is used (only) for the literal derived from a + -- "foreign label" declaration. + -- string argument is the name of a symbol. This literal + -- refers to the *address* of the label. + | MachLabel FastString -- always an Addr# + (Maybe Int) -- the size (in bytes) of the arguments + -- the label expects. Only applicable with + -- 'stdcall' labels. + -- Just x => "@<x>" will be appended to label + -- name when emitting asm. +\end{code} + +Binary instance + +\begin{code} +instance Binary Literal where + put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa + put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab + put_ bh (MachNullAddr) = do putByte bh 2 + put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad + put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae + put_ bh (MachWord af) = do putByte bh 5; put_ bh af + put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag + put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah + put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai + put_ bh (MachLabel aj mb) = do putByte bh 9; put_ bh aj ; put_ bh mb + get bh = do + h <- getByte bh + case h of + 0 -> do + aa <- get bh + return (MachChar aa) + 1 -> do + ab <- get bh + return (MachStr ab) + 2 -> do + return (MachNullAddr) + 3 -> do + ad <- get bh + return (MachInt ad) + 4 -> do + ae <- get bh + return (MachInt64 ae) + 5 -> do + af <- get bh + return (MachWord af) + 6 -> do + ag <- get bh + return (MachWord64 ag) + 7 -> do + ah <- get bh + return (MachFloat ah) + 8 -> do + ai <- get bh + return (MachDouble ai) + 9 -> do + aj <- get bh + mb <- get bh + return (MachLabel aj mb) +\end{code} + +\begin{code} +instance Outputable Literal where + ppr lit = pprLit lit + +instance Show Literal where + showsPrec p lit = showsPrecSDoc p (ppr lit) + +instance Eq Literal where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +instance Ord Literal where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpLit a b +\end{code} + + + Construction + ~~~~~~~~~~~~ +\begin{code} +mkMachInt, mkMachWord, mkMachInt64, mkMachWord64 :: Integer -> Literal + +mkMachInt x = -- ASSERT2( inIntRange x, integer x ) + -- Not true: you can write out of range Int# literals + -- For example, one can write (intToWord# 0xffff0000) to + -- get a particular Word bit-pattern, and there's no other + -- convenient way to write such literals, which is why we allow it. + MachInt x +mkMachWord x = -- ASSERT2( inWordRange x, integer x ) + MachWord x +mkMachInt64 x = MachInt64 x +mkMachWord64 x = MachWord64 x + +mkStringLit :: String -> Literal +mkStringLit s = MachStr (mkFastString s) -- stored UTF-8 encoded + +inIntRange, inWordRange :: Integer -> Bool +inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT +inWordRange x = x >= 0 && x <= tARGET_MAX_WORD + +inCharRange :: Char -> Bool +inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR + +isZeroLit :: Literal -> Bool +isZeroLit (MachInt 0) = True +isZeroLit (MachInt64 0) = True +isZeroLit (MachWord 0) = True +isZeroLit (MachWord64 0) = True +isZeroLit (MachFloat 0) = True +isZeroLit (MachDouble 0) = True +isZeroLit other = False +\end{code} + + Coercions + ~~~~~~~~~ +\begin{code} +word2IntLit, int2WordLit, + narrow8IntLit, narrow16IntLit, narrow32IntLit, + narrow8WordLit, narrow16WordLit, narrow32WordLit, + char2IntLit, int2CharLit, + float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, + float2DoubleLit, double2FloatLit + :: Literal -> Literal + +word2IntLit (MachWord w) + | w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1) + | otherwise = MachInt w + +int2WordLit (MachInt i) + | i < 0 = MachWord (1 + tARGET_MAX_WORD + i) -- (-1) ---> tARGET_MAX_WORD + | otherwise = MachWord i + +narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8)) +narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16)) +narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32)) +narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8)) +narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16)) +narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32)) + +char2IntLit (MachChar c) = MachInt (toInteger (ord c)) +int2CharLit (MachInt i) = MachChar (chr (fromInteger i)) + +float2IntLit (MachFloat f) = MachInt (truncate f) +int2FloatLit (MachInt i) = MachFloat (fromInteger i) + +double2IntLit (MachDouble f) = MachInt (truncate f) +int2DoubleLit (MachInt i) = MachDouble (fromInteger i) + +float2DoubleLit (MachFloat f) = MachDouble f +double2FloatLit (MachDouble d) = MachFloat d + +nullAddrLit :: Literal +nullAddrLit = MachNullAddr +\end{code} + + Predicates + ~~~~~~~~~~ +\begin{code} +litIsTrivial :: Literal -> Bool +-- True if there is absolutely no penalty to duplicating the literal +-- c.f. CoreUtils.exprIsTrivial +-- False principally of strings +litIsTrivial (MachStr _) = False +litIsTrivial other = True + +litIsDupable :: Literal -> Bool +-- True if code space does not go bad if we duplicate this literal +-- c.f. CoreUtils.exprIsDupable +-- Currently we treat it just like litIsTrivial +litIsDupable (MachStr _) = False +litIsDupable other = True + +litSize :: Literal -> Int +-- Used by CoreUnfold.sizeExpr +litSize (MachStr str) = 1 + ((lengthFS str + 3) `div` 4) + -- Every literal has size at least 1, otherwise + -- f "x" + -- might be too small + -- [Sept03: make literal strings a bit bigger to avoid fruitless + -- duplication of little strings] +litSize _other = 1 +\end{code} + + Types + ~~~~~ +\begin{code} +literalType :: Literal -> Type +literalType MachNullAddr = addrPrimTy +literalType (MachChar _) = charPrimTy +literalType (MachStr _) = addrPrimTy +literalType (MachInt _) = intPrimTy +literalType (MachWord _) = wordPrimTy +literalType (MachInt64 _) = int64PrimTy +literalType (MachWord64 _) = word64PrimTy +literalType (MachFloat _) = floatPrimTy +literalType (MachDouble _) = doublePrimTy +literalType (MachLabel _ _) = addrPrimTy +\end{code} + + + Comparison + ~~~~~~~~~~ +\begin{code} +cmpLit (MachChar a) (MachChar b) = a `compare` b +cmpLit (MachStr a) (MachStr b) = a `compare` b +cmpLit (MachNullAddr) (MachNullAddr) = EQ +cmpLit (MachInt a) (MachInt b) = a `compare` b +cmpLit (MachWord a) (MachWord b) = a `compare` b +cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b +cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b +cmpLit (MachFloat a) (MachFloat b) = a `compare` b +cmpLit (MachDouble a) (MachDouble b) = a `compare` b +cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b +cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT + | otherwise = GT + +litTag (MachChar _) = _ILIT(1) +litTag (MachStr _) = _ILIT(2) +litTag (MachNullAddr) = _ILIT(3) +litTag (MachInt _) = _ILIT(4) +litTag (MachWord _) = _ILIT(5) +litTag (MachInt64 _) = _ILIT(6) +litTag (MachWord64 _) = _ILIT(7) +litTag (MachFloat _) = _ILIT(8) +litTag (MachDouble _) = _ILIT(9) +litTag (MachLabel _ _) = _ILIT(10) +\end{code} + + Printing + ~~~~~~~~ +* MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo") + exceptions: MachFloat gets an initial keyword prefix. + +\begin{code} +pprLit (MachChar ch) = pprHsChar ch +pprLit (MachStr s) = pprHsString s +pprLit (MachInt i) = pprIntVal i +pprLit (MachInt64 i) = ptext SLIT("__int64") <+> integer i +pprLit (MachWord w) = ptext SLIT("__word") <+> integer w +pprLit (MachWord64 w) = ptext SLIT("__word64") <+> integer w +pprLit (MachFloat f) = ptext SLIT("__float") <+> rational f +pprLit (MachDouble d) = rational d +pprLit (MachNullAddr) = ptext SLIT("__NULL") +pprLit (MachLabel l mb) = ptext SLIT("__label") <+> + case mb of + Nothing -> pprHsString l + Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) + +pprIntVal :: Integer -> SDoc +-- Print negative integers with parens to be sure it's unambiguous +pprIntVal i | i < 0 = parens (integer i) + | otherwise = integer i +\end{code} + + +%************************************************************************ +%* * +\subsection{Hashing} +%* * +%************************************************************************ + +Hash values should be zero or a positive integer. No negatives please. +(They mess up the UniqFM for some reason.) + +\begin{code} +hashLiteral :: Literal -> Int +hashLiteral (MachChar c) = ord c + 1000 -- Keep it out of range of common ints +hashLiteral (MachStr s) = hashFS s +hashLiteral (MachNullAddr) = 0 +hashLiteral (MachInt i) = hashInteger i +hashLiteral (MachInt64 i) = hashInteger i +hashLiteral (MachWord i) = hashInteger i +hashLiteral (MachWord64 i) = hashInteger i +hashLiteral (MachFloat r) = hashRational r +hashLiteral (MachDouble r) = hashRational r +hashLiteral (MachLabel s _) = hashFS s + +hashRational :: Rational -> Int +hashRational r = hashInteger (numerator r) + +hashInteger :: Integer -> Int +hashInteger i = 1 + abs (fromInteger (i `rem` 10000)) + -- The 1+ is to avoid zero, which is a Bad Number + -- since we use * to combine hash values + +hashFS :: FastString -> Int +hashFS s = iBox (uniqueOfFS s) +\end{code} diff --git a/compiler/basicTypes/MkId.hi-boot-5 b/compiler/basicTypes/MkId.hi-boot-5 new file mode 100644 index 0000000000..ff901a5840 --- /dev/null +++ b/compiler/basicTypes/MkId.hi-boot-5 @@ -0,0 +1,3 @@ +__interface MkId 1 0 where +__export MkId mkDataConIds ; +1 mkDataConIds :: Name.Name -> Name.Name -> DataCon.DataCon -> DataCon.DataConIds ; diff --git a/compiler/basicTypes/MkId.hi-boot-6 b/compiler/basicTypes/MkId.hi-boot-6 new file mode 100644 index 0000000000..d3f22527f3 --- /dev/null +++ b/compiler/basicTypes/MkId.hi-boot-6 @@ -0,0 +1,5 @@ +module MkId where + +mkDataConIds :: Name.Name -> Name.Name -> DataCon.DataCon -> DataCon.DataConIds + + diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs new file mode 100644 index 0000000000..84b3546e62 --- /dev/null +++ b/compiler/basicTypes/MkId.lhs @@ -0,0 +1,1044 @@ +% +% (c) The AQUA Project, Glasgow University, 1998 +% +\section[StdIdInfo]{Standard unfoldings} + +This module contains definitions for the IdInfo for things that +have a standard form, namely: + + * data constructors + * record selectors + * method and superclass selectors + * primitive operations + +\begin{code} +module MkId ( + mkDictFunId, mkDefaultMethodId, + mkDictSelId, + + mkDataConIds, + mkRecordSelId, + mkPrimOpId, mkFCallId, + + mkReboxingAlt, mkNewTypeBody, + + -- And some particular Ids; see below for why they are wired in + wiredInIds, ghcPrimIds, + unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId, + lazyId, lazyIdUnfolding, lazyIdKey, + + mkRuntimeErrorApp, + rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, eRROR_ID, + + unsafeCoerceName + ) where + +#include "HsVersions.h" + + +import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict ) +import Rules ( mkSpecInfo ) +import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, + realWorldStatePrimTy, addrPrimTy + ) +import TysWiredIn ( charTy, mkListTy ) +import PrelRules ( primOpRules ) +import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes ) +import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, + mkTyConApp, mkTyVarTys, mkClassPred, + mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, + isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, + tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta + ) +import CoreUtils ( exprType ) +import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding ) +import Literal ( nullAddrLit, mkStringLit ) +import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel, + tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon ) +import Class ( Class, classTyCon, classSelIds ) +import Var ( Id, TyVar, Var ) +import VarSet ( isEmptyVarSet, subVarSet, varSetElems ) +import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) ) +import OccName ( mkOccNameFS, varName ) +import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag ) +import ForeignCall ( ForeignCall ) +import DataCon ( DataCon, DataConIds(..), dataConTyVars, + dataConFieldLabels, dataConRepArity, dataConResTys, + dataConRepArgTys, dataConRepType, + dataConSig, dataConStrictMarks, dataConExStricts, + splitProductType, isVanillaDataCon, dataConFieldType, + dataConInstOrigArgTys + ) +import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, + mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId, + mkTemplateLocal, idName + ) +import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo, + setArityInfo, setSpecInfo, setCafInfo, + setAllStrictnessInfo, vanillaIdInfo, + GlobalIdDetails(..), CafInfo(..) + ) +import NewDemand ( mkStrictSig, DmdResult(..), + mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR, + Demand(..), Demands(..) ) +import DmdAnal ( dmdAnalTopRhs ) +import CoreSyn +import Unique ( mkBuiltinUnique, mkPrimOpIdUnique ) +import Maybes +import PrelNames +import Util ( dropList, isSingleton ) +import Outputable +import FastString +import ListSetOps ( assoc ) +\end{code} + +%************************************************************************ +%* * +\subsection{Wired in Ids} +%* * +%************************************************************************ + +\begin{code} +wiredInIds + = [ -- These error-y things are wired in because we don't yet have + -- a way to express in an interface file that the result type variable + -- is 'open'; that is can be unified with an unboxed type + -- + -- [The interface file format now carry such information, but there's + -- no way yet of expressing at the definition site for these + -- error-reporting functions that they have an 'open' + -- result type. -- sof 1/99] + + eRROR_ID, -- This one isn't used anywhere else in the compiler + -- But we still need it in wiredInIds so that when GHC + -- compiles a program that mentions 'error' we don't + -- import its type from the interface file; we just get + -- the Id defined here. Which has an 'open-tyvar' type. + + rUNTIME_ERROR_ID, + iRREFUT_PAT_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, + nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, + rEC_CON_ERROR_ID, + + lazyId + ] ++ ghcPrimIds + +-- These Ids are exported from GHC.Prim +ghcPrimIds + = [ -- These can't be defined in Haskell, but they have + -- perfectly reasonable unfoldings in Core + realWorldPrimId, + unsafeCoerceId, + nullAddrId, + seqId + ] +\end{code} + +%************************************************************************ +%* * +\subsection{Data constructors} +%* * +%************************************************************************ + +The wrapper for a constructor is an ordinary top-level binding that evaluates +any strict args, unboxes any args that are going to be flattened, and calls +the worker. + +We're going to build a constructor that looks like: + + data (Data a, C b) => T a b = T1 !a !Int b + + T1 = /\ a b -> + \d1::Data a, d2::C b -> + \p q r -> case p of { p -> + case q of { q -> + Con T1 [a,b] [p,q,r]}} + +Notice that + +* d2 is thrown away --- a context in a data decl is used to make sure + one *could* construct dictionaries at the site the constructor + is used, but the dictionary isn't actually used. + +* We have to check that we can construct Data dictionaries for + the types a and Int. Once we've done that we can throw d1 away too. + +* We use (case p of q -> ...) to evaluate p, rather than "seq" because + all that matters is that the arguments are evaluated. "seq" is + very careful to preserve evaluation order, which we don't need + to be here. + + You might think that we could simply give constructors some strictness + info, like PrimOps, and let CoreToStg do the let-to-case transformation. + But we don't do that because in the case of primops and functions strictness + is a *property* not a *requirement*. In the case of constructors we need to + do something active to evaluate the argument. + + Making an explicit case expression allows the simplifier to eliminate + it in the (common) case where the constructor arg is already evaluated. + + +\begin{code} +mkDataConIds :: Name -> Name -> DataCon -> DataConIds + -- Makes the *worker* for the data constructor; that is, the function + -- that takes the reprsentation arguments and builds the constructor. +mkDataConIds wrap_name wkr_name data_con + | isNewTyCon tycon + = NewDC nt_wrap_id + + | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper + = AlgDC (Just alg_wrap_id) wrk_id + + | otherwise -- Algebraic, no wrapper + = AlgDC Nothing wrk_id + where + (tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con + + dict_tys = mkPredTys theta + all_arg_tys = dict_tys ++ orig_arg_tys + result_ty = mkTyConApp tycon res_tys + + wrap_ty = mkForAllTys tyvars (mkFunTys all_arg_tys result_ty) + -- We used to include the stupid theta in the wrapper's args + -- but now we don't. Instead the type checker just injects these + -- extra constraints where necessary. + + ----------- Worker (algebraic data types only) -------------- + wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name + (dataConRepType data_con) wkr_info + + wkr_arity = dataConRepArity data_con + wkr_info = noCafIdInfo + `setArityInfo` wkr_arity + `setAllStrictnessInfo` Just wkr_sig + `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, + -- even if arity = 0 + + wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info) + -- Notice that we do *not* say the worker is strict + -- even if the data constructor is declared strict + -- e.g. data T = MkT !(Int,Int) + -- Why? Because the *wrapper* is strict (and its unfolding has case + -- expresssions that do the evals) but the *worker* itself is not. + -- If we pretend it is strict then when we see + -- case x of y -> $wMkT y + -- the simplifier thinks that y is "sure to be evaluated" (because + -- $wMkT is strict) and drops the case. No, $wMkT is not strict. + -- + -- When the simplifer sees a pattern + -- case e of MkT x -> ... + -- it uses the dataConRepStrictness of MkT to mark x as evaluated; + -- but that's fine... dataConRepStrictness comes from the data con + -- not from the worker Id. + + cpr_info | isProductTyCon tycon && + isDataTyCon tycon && + wkr_arity > 0 && + wkr_arity <= mAX_CPR_SIZE = retCPR + | otherwise = TopRes + -- RetCPR is only true for products that are real data types; + -- that is, not unboxed tuples or [non-recursive] newtypes + + ----------- Wrappers for newtypes -------------- + nt_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty nt_wrap_info + nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` 1 -- Arity 1 + `setUnfoldingInfo` newtype_unf + newtype_unf = ASSERT( isVanillaDataCon data_con && + isSingleton orig_arg_tys ) + -- No existentials on a newtype, but it can have a context + -- e.g. newtype Eq a => T a = MkT (...) + mkTopUnfolding $ Note InlineMe $ + mkLams tyvars $ Lam id_arg1 $ + mkNewTypeBody tycon result_ty (Var id_arg1) + + id_arg1 = mkTemplateLocal 1 (head orig_arg_tys) + + ----------- Wrappers for algebraic data types -------------- + alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info + alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` alg_arity + -- It's important to specify the arity, so that partial + -- applications are treated as values + `setUnfoldingInfo` alg_unf + `setAllStrictnessInfo` Just wrap_sig + + all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con + wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info) + arg_dmds = map mk_dmd all_strict_marks + mk_dmd str | isMarkedStrict str = evalDmd + | otherwise = lazyDmd + -- The Cpr info can be important inside INLINE rhss, where the + -- wrapper constructor isn't inlined. + -- And the argument strictness can be important too; we + -- may not inline a contructor when it is partially applied. + -- For example: + -- data W = C !Int !Int !Int + -- ...(let w = C x in ...(w p q)...)... + -- we want to see that w is strict in its two arguments + + alg_unf = mkTopUnfolding $ Note InlineMe $ + mkLams tyvars $ + mkLams dict_args $ mkLams id_args $ + foldr mk_case con_app + (zip (dict_args ++ id_args) all_strict_marks) + i3 [] + + con_app i rep_ids = mkApps (Var wrk_id) + (map varToCoreExpr (tyvars ++ reverse rep_ids)) + + (dict_args,i2) = mkLocals 1 dict_tys + (id_args,i3) = mkLocals i2 orig_arg_tys + alg_arity = i3-1 + + mk_case + :: (Id, StrictnessMark) -- Arg, strictness + -> (Int -> [Id] -> CoreExpr) -- Body + -> Int -- Next rep arg id + -> [Id] -- Rep args so far, reversed + -> CoreExpr + mk_case (arg,strict) body i rep_args + = case strict of + NotMarkedStrict -> body i (arg:rep_args) + MarkedStrict + | isUnLiftedType (idType arg) -> body i (arg:rep_args) + | otherwise -> + Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))] + + MarkedUnboxed + -> case splitProductType "do_unbox" (idType arg) of + (tycon, tycon_args, con, tys) -> + Case (Var arg) arg result_ty + [(DataAlt con, + con_args, + body i' (reverse con_args ++ rep_args))] + where + (con_args, i') = mkLocals i tys + +mAX_CPR_SIZE :: Arity +mAX_CPR_SIZE = 10 +-- We do not treat very big tuples as CPR-ish: +-- a) for a start we get into trouble because there aren't +-- "enough" unboxed tuple types (a tiresome restriction, +-- but hard to fix), +-- b) more importantly, big unboxed tuples get returned mainly +-- on the stack, and are often then allocated in the heap +-- by the caller. So doing CPR for them may in fact make +-- things worse. + +mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n) + where + n = length tys +\end{code} + + +%************************************************************************ +%* * +\subsection{Record selectors} +%* * +%************************************************************************ + +We're going to build a record selector unfolding that looks like this: + + data T a b c = T1 { ..., op :: a, ...} + | T2 { ..., op :: a, ...} + | T3 + + sel = /\ a b c -> \ d -> case d of + T1 ... x ... -> x + T2 ... x ... -> x + other -> error "..." + +Similarly for newtypes + + newtype N a = MkN { unN :: a->a } + + unN :: N a -> a -> a + unN n = coerce (a->a) n + +We need to take a little care if the field has a polymorphic type: + + data R = R { f :: forall a. a->a } + +Then we want + + f :: forall a. R -> a -> a + f = /\ a \ r = case r of + R f -> f a + +(not f :: R -> forall a. a->a, which gives the type inference mechanism +problems at call sites) + +Similarly for (recursive) newtypes + + newtype N = MkN { unN :: forall a. a->a } + + unN :: forall b. N -> b -> b + unN = /\b -> \n:N -> (coerce (forall a. a->a) n) + + +Note [Naughty record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "naughty" field is one for which we can't define a record +selector, because an existential type variable would escape. For example: + data T = forall a. MkT { x,y::a } +We obviously can't define + x (MkT v _) = v +Nevertheless we *do* put a RecordSelId into the type environment +so that if the user tries to use 'x' as a selector we can bleat +helpfully, rather than saying unhelpfully that 'x' is not in scope. +Hence the sel_naughty flag, to identify record selcectors that don't really exist. + +In general, a field is naughty if its type mentions a type variable that +isn't in the result type of the constructor. + +For GADTs, we require that all constructors with a common field 'f' have the same +result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] +E.g. + data T where + T1 { f :: a } :: T [a] + T2 { f :: a, y :: b } :: T [a] +and now the selector takes that type as its argument: + f :: forall a. T [a] -> a + f t = case t of + T1 { f = v } -> v + T2 { f = v } -> v +Note the forall'd tyvars of the selector are just the free tyvars +of the result type; there may be other tyvars in the constructor's +type (e.g. 'b' in T2). + +\begin{code} + +-- XXX - autrijus - +-- Plan: 1. Determine naughtiness by comparing field type vs result type +-- 2. Install naughty ones with selector_ty of type _|_ and fill in mzero for info +-- 3. If it's not naughty, do the normal plan. + +mkRecordSelId :: TyCon -> FieldLabel -> Id +mkRecordSelId tycon field_label + -- Assumes that all fields with the same field label have the same type + | is_naughty = naughty_id + | otherwise = sel_id + where + is_naughty = not (tyVarsOfType field_ty `subVarSet` tyvar_set) + sel_id_details = RecordSelId tycon field_label is_naughty + + -- Escapist case here for naughty construcotrs + -- We give it no IdInfo, and a type of forall a.a (never looked at) + naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo + forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) + + -- Normal case starts here + sel_id = mkGlobalId sel_id_details field_label selector_ty info + data_cons = tyConDataCons tycon + data_cons_w_field = filter has_field data_cons -- Can't be empty! + has_field con = field_label `elem` dataConFieldLabels con + + con1 = head data_cons_w_field + res_tys = dataConResTys con1 + tyvar_set = tyVarsOfTypes res_tys + tyvars = varSetElems tyvar_set + data_ty = mkTyConApp tycon res_tys + field_ty = dataConFieldType con1 field_label + + -- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over + -- just the dictionaries in the types of the constructors that contain + -- the relevant field. [The Report says that pattern matching on a + -- constructor gives the same constraints as applying it.] Urgh. + -- + -- However, not all data cons have all constraints (because of + -- BuildTyCl.mkDataConStupidTheta). So we need to find all the data cons + -- involved in the pattern match and take the union of their constraints. + stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field) + n_stupid_dicts = length stupid_dict_tys + + (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty + field_dict_tys = mkPredTys field_theta + n_field_dict_tys = length field_dict_tys + -- If the field has a universally quantified type we have to + -- be a bit careful. Suppose we have + -- data R = R { op :: forall a. Foo a => a -> a } + -- Then we can't give op the type + -- op :: R -> forall a. Foo a => a -> a + -- because the typechecker doesn't understand foralls to the + -- right of an arrow. The "right" type to give it is + -- op :: forall a. Foo a => R -> a -> a + -- But then we must generate the right unfolding too: + -- op = /\a -> \dfoo -> \ r -> + -- case r of + -- R op -> op a dfoo + -- Note that this is exactly the type we'd infer from a user defn + -- op (R op) = op + + selector_ty :: Type + selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $ + mkFunTys stupid_dict_tys $ mkFunTys field_dict_tys $ + mkFunTy data_ty field_tau + + arity = 1 + n_stupid_dicts + n_field_dict_tys + + (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs + -- Use the demand analyser to work out strictness. + -- With all this unpackery it's not easy! + + info = noCafIdInfo + `setCafInfo` caf_info + `setArityInfo` arity + `setUnfoldingInfo` mkTopUnfolding rhs_w_str + `setAllStrictnessInfo` Just strict_sig + + -- Allocate Ids. We do it a funny way round because field_dict_tys is + -- almost always empty. Also note that we use max_dict_tys + -- rather than n_dict_tys, because the latter gives an infinite loop: + -- n_dict tys depends on the_alts, which depens on arg_ids, which depends + -- on arity, which depends on n_dict tys. Sigh! Mega sigh! + stupid_dict_ids = mkTemplateLocalsNum 1 stupid_dict_tys + max_stupid_dicts = length (tyConStupidTheta tycon) + field_dict_base = max_stupid_dicts + 1 + field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys + dict_id_base = field_dict_base + n_field_dict_tys + data_id = mkTemplateLocal dict_id_base data_ty + arg_base = dict_id_base + 1 + + the_alts :: [CoreAlt] + the_alts = map mk_alt data_cons_w_field -- Already sorted by data-con + no_default = length data_cons == length data_cons_w_field -- No default needed + + default_alt | no_default = [] + | otherwise = [(DEFAULT, [], error_expr)] + + -- The default branch may have CAF refs, because it calls recSelError etc. + caf_info | no_default = NoCafRefs + | otherwise = MayHaveCafRefs + + sel_rhs = mkLams tyvars $ mkLams field_tyvars $ + mkLams stupid_dict_ids $ mkLams field_dict_ids $ + Lam data_id $ sel_body + + sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id)) + | otherwise = Case (Var data_id) data_id field_tau (default_alt ++ the_alts) + + mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids + -- We pull the field lambdas to the top, so we need to + -- apply them in the body. For example: + -- data T = MkT { foo :: forall a. a->a } + -- + -- foo :: forall a. T -> a -> a + -- foo = /\a. \t:T. case t of { MkT f -> f a } + + mk_alt data_con + = -- In the non-vanilla case, the pattern must bind type variables and + -- the context stuff; hence the arg_prefix binding below + mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) + (mk_result (Var the_arg_id)) + where + (arg_prefix, arg_ids) + | isVanillaDataCon data_con -- Instantiate from commmon base + = ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys)) + | otherwise -- The case pattern binds type variables, which are used + -- in the types of the arguments of the pattern + = (dc_tyvars ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta), + mkTemplateLocalsNum arg_base' dc_arg_tys) + + (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con + arg_base' = arg_base + length dc_theta + + unpack_base = arg_base' + length dc_arg_tys + uniqs = map mkBuiltinUnique [unpack_base..] + + the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label + field_lbls = dataConFieldLabels data_con + + error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg + full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id]) + + +-- (mkReboxingAlt us con xs rhs) basically constructs the case +-- alternative (con, xs, rhs) +-- but it does the reboxing necessary to construct the *source* +-- arguments, xs, from the representation arguments ys. +-- For example: +-- data T = MkT !(Int,Int) Bool +-- +-- mkReboxingAlt MkT [x,b] r +-- = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r) +-- +-- mkDataAlt should really be in DataCon, but it can't because +-- it manipulates CoreSyn. + +mkReboxingAlt + :: [Unique] -- Uniques for the new Ids + -> DataCon + -> [Var] -- Source-level args, including existential dicts + -> CoreExpr -- RHS + -> CoreAlt + +mkReboxingAlt us con args rhs + | not (any isMarkedUnboxed stricts) + = (DataAlt con, args, rhs) + + | otherwise + = let + (binds, args') = go args stricts us + in + (DataAlt con, args', mkLets binds rhs) + + where + stricts = dataConExStricts con ++ dataConStrictMarks con + + go [] stricts us = ([], []) + + -- Type variable case + go (arg:args) stricts us + | isTyVar arg + = let (binds, args') = go args stricts us + in (binds, arg:args') + + -- Term variable case + go (arg:args) (str:stricts) us + | isMarkedUnboxed str + = let + (_, tycon_args, pack_con, con_arg_tys) + = splitProductType "mkReboxingAlt" (idType arg) + + unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys + (binds, args') = go args stricts (dropList con_arg_tys us) + con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args) + in + (NonRec arg con_app : binds, unpacked_args ++ args') + + | otherwise + = let (binds, args') = go args stricts us + in (binds, arg:args') +\end{code} + + +%************************************************************************ +%* * +\subsection{Dictionary selectors} +%* * +%************************************************************************ + +Selecting a field for a dictionary. If there is just one field, then +there's nothing to do. + +Dictionary selectors may get nested forall-types. Thus: + + class Foo a where + op :: forall b. Ord b => a -> b -> b + +Then the top-level type for op is + + op :: forall a. Foo a => + forall b. Ord b => + a -> b -> b + +This is unlike ordinary record selectors, which have all the for-alls +at the outside. When dealing with classes it's very convenient to +recover the original type signature from the class op selector. + +\begin{code} +mkDictSelId :: Name -> Class -> Id +mkDictSelId name clas + = mkGlobalId (ClassOpId clas) name sel_ty info + where + sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id)) + -- We can't just say (exprType rhs), because that would give a type + -- C a -> C a + -- for a single-op class (after all, the selector is the identity) + -- But it's type must expose the representation of the dictionary + -- to gat (say) C a -> (a -> a) + + info = noCafIdInfo + `setArityInfo` 1 + `setUnfoldingInfo` mkTopUnfolding rhs + `setAllStrictnessInfo` Just strict_sig + + -- We no longer use 'must-inline' on record selectors. They'll + -- inline like crazy if they scrutinise a constructor + + -- The strictness signature is of the form U(AAAVAAAA) -> T + -- where the V depends on which item we are selecting + -- It's worth giving one, so that absence info etc is generated + -- even if the selector isn't inlined + strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes) + arg_dmd | isNewTyCon tycon = evalDmd + | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs + | id <- arg_ids ]) + + tycon = classTyCon clas + [data_con] = tyConDataCons tycon + tyvars = dataConTyVars data_con + arg_tys = dataConRepArgTys data_con + the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name + + pred = mkClassPred clas (mkTyVarTys tyvars) + (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys) + + rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $ + mkNewTypeBody tycon (head arg_tys) (Var dict_id) + | otherwise = mkLams tyvars $ Lam dict_id $ + Case (Var dict_id) dict_id (idType the_arg_id) + [(DataAlt data_con, arg_ids, Var the_arg_id)] + +mkNewTypeBody tycon result_ty result_expr + -- Adds a coerce where necessary + -- Used for both wrapping and unwrapping + | isRecursiveTyCon tycon -- Recursive case; use a coerce + = Note (Coerce result_ty (exprType result_expr)) result_expr + | otherwise -- Normal case + = result_expr +\end{code} + + +%************************************************************************ +%* * +\subsection{Primitive operations +%* * +%************************************************************************ + +\begin{code} +mkPrimOpId :: PrimOp -> Id +mkPrimOpId prim_op + = id + where + (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op + ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) + name = mkWiredInName gHC_PRIM (primOpOcc prim_op) + (mkPrimOpIdUnique (primOpTag prim_op)) + Nothing (AnId id) UserSyntax + id = mkGlobalId (PrimOpId prim_op) name ty info + + info = noCafIdInfo + `setSpecInfo` mkSpecInfo (primOpRules prim_op name) + `setArityInfo` arity + `setAllStrictnessInfo` Just strict_sig + +-- For each ccall we manufacture a separate CCallOpId, giving it +-- a fresh unique, a type that is correct for this particular ccall, +-- and a CCall structure that gives the correct details about calling +-- convention etc. +-- +-- The *name* of this Id is a local name whose OccName gives the full +-- details of the ccall, type and all. This means that the interface +-- file reader can reconstruct a suitable Id + +mkFCallId :: Unique -> ForeignCall -> Type -> Id +mkFCallId uniq fcall ty + = ASSERT( isEmptyVarSet (tyVarsOfType ty) ) + -- A CCallOpId should have no free type variables; + -- when doing substitutions won't substitute over it + mkGlobalId (FCallId fcall) name ty info + where + occ_str = showSDoc (braces (ppr fcall <+> ppr ty)) + -- The "occurrence name" of a ccall is the full info about the + -- ccall; it is encoded, but may have embedded spaces etc! + + name = mkFCallName uniq occ_str + + info = noCafIdInfo + `setArityInfo` arity + `setAllStrictnessInfo` Just strict_sig + + (_, tau) = tcSplitForAllTys ty + (arg_tys, _) = tcSplitFunTys tau + arity = length arg_tys + strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes) +\end{code} + + +%************************************************************************ +%* * +\subsection{DictFuns and default methods} +%* * +%************************************************************************ + +Important notes about dict funs and default methods +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dict funs and default methods are *not* ImplicitIds. Their definition +involves user-written code, so we can't figure out their strictness etc +based on fixed info, as we can for constructors and record selectors (say). + +We build them as LocalIds, but with External Names. This ensures that +they are taken to account by free-variable finding and dependency +analysis (e.g. CoreFVs.exprFreeVars). + +Why shouldn't they be bound as GlobalIds? Because, in particular, if +they are globals, the specialiser floats dict uses above their defns, +which prevents good simplifications happening. Also the strictness +analyser treats a occurrence of a GlobalId as imported and assumes it +contains strictness in its IdInfo, which isn't true if the thing is +bound in the same module as the occurrence. + +It's OK for dfuns to be LocalIds, because we form the instance-env to +pass on to the next module (md_insts) in CoreTidy, afer tidying +and globalising the top-level Ids. + +BUT make sure they are *exported* LocalIds (mkExportedLocalId) so +that they aren't discarded by the occurrence analyser. + +\begin{code} +mkDefaultMethodId dm_name ty = mkExportedLocalId dm_name ty + +mkDictFunId :: Name -- Name to use for the dict fun; + -> [TyVar] + -> ThetaType + -> Class + -> [Type] + -> Id + +mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys + = mkExportedLocalId dfun_name dfun_ty + where + dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) + +{- 1 dec 99: disable the Mark Jones optimisation for the sake + of compatibility with Hugs. + See `types/InstEnv' for a discussion related to this. + + (class_tyvars, sc_theta, _, _) = classBigSig clas + not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys)) + sc_theta' = substClasses (zipTopTvSubst class_tyvars inst_tys) sc_theta + dfun_theta = case inst_decl_theta of + [] -> [] -- If inst_decl_theta is empty, then we don't + -- want to have any dict arguments, so that we can + -- expose the constant methods. + + other -> nub (inst_decl_theta ++ filter not_const sc_theta') + -- Otherwise we pass the superclass dictionaries to + -- the dictionary function; the Mark Jones optimisation. + -- + -- NOTE the "nub". I got caught by this one: + -- class Monad m => MonadT t m where ... + -- instance Monad m => MonadT (EnvT env) m where ... + -- Here, the inst_decl_theta has (Monad m); but so + -- does the sc_theta'! + -- + -- NOTE the "not_const". I got caught by this one too: + -- class Foo a => Baz a b where ... + -- instance Wob b => Baz T b where.. + -- Now sc_theta' has Foo T +-} +\end{code} + + +%************************************************************************ +%* * +\subsection{Un-definable} +%* * +%************************************************************************ + +These Ids can't be defined in Haskell. They could be defined in +unfoldings in the wired-in GHC.Prim interface file, but we'd have to +ensure that they were definitely, definitely inlined, because there is +no curried identifier for them. That's what mkCompulsoryUnfolding +does. If we had a way to get a compulsory unfolding from an interface +file, we could do that, but we don't right now. + +unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that +just gets expanded into a type coercion wherever it occurs. Hence we +add it as a built-in Id with an unfolding here. + +The type variables we use here are "open" type variables: this means +they can unify with both unlifted and lifted types. Hence we provide +another gun with which to shoot yourself in the foot. + +\begin{code} +mkWiredInIdName mod fs uniq id + = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax + +unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId +nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId +seqName = mkWiredInIdName gHC_PRIM FSLIT("seq") seqIdKey seqId +realWorldName = mkWiredInIdName gHC_PRIM FSLIT("realWorld#") realWorldPrimIdKey realWorldPrimId +lazyIdName = mkWiredInIdName pREL_BASE FSLIT("lazy") lazyIdKey lazyId + +errorName = mkWiredInIdName pREL_ERR FSLIT("error") errorIdKey eRROR_ID +recSelErrorName = mkWiredInIdName pREL_ERR FSLIT("recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID +runtimeErrorName = mkWiredInIdName pREL_ERR FSLIT("runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID +irrefutPatErrorName = mkWiredInIdName pREL_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID +recConErrorName = mkWiredInIdName pREL_ERR FSLIT("recConError") recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = mkWiredInIdName pREL_ERR FSLIT("patError") patErrorIdKey pAT_ERROR_ID +noMethodBindingErrorName = mkWiredInIdName pREL_ERR FSLIT("noMethodBindingError") + noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID +nonExhaustiveGuardsErrorName + = mkWiredInIdName pREL_ERR FSLIT("nonExhaustiveGuardsError") + nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID +\end{code} + +\begin{code} +-- unsafeCoerce# :: forall a b. a -> b +unsafeCoerceId + = pcMiscPrelId unsafeCoerceName ty info + where + info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs + + + ty = mkForAllTys [openAlphaTyVar,openBetaTyVar] + (mkFunTy openAlphaTy openBetaTy) + [x] = mkTemplateLocals [openAlphaTy] + rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $ + Note (Coerce openBetaTy openAlphaTy) (Var x) + +-- nullAddr# :: Addr# +-- The reason is is here is because we don't provide +-- a way to write this literal in Haskell. +nullAddrId + = pcMiscPrelId nullAddrName addrPrimTy info + where + info = noCafIdInfo `setUnfoldingInfo` + mkCompulsoryUnfolding (Lit nullAddrLit) + +seqId + = pcMiscPrelId seqName ty info + where + info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs + + + ty = mkForAllTys [alphaTyVar,openBetaTyVar] + (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy)) + [x,y] = mkTemplateLocals [alphaTy, openBetaTy] +-- gaw 2004 + rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)]) + +-- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) +-- Used to lazify pseq: pseq a b = a `seq` lazy b +-- No unfolding: it gets "inlined" by the worker/wrapper pass +-- Also, no strictness: by being a built-in Id, it overrides all +-- the info in PrelBase.hi. This is important, because the strictness +-- analyser will spot it as strict! +lazyId + = pcMiscPrelId lazyIdName ty info + where + info = noCafIdInfo + ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) + +lazyIdUnfolding :: CoreExpr -- Used to expand LazyOp after strictness anal +lazyIdUnfolding = mkLams [openAlphaTyVar,x] (Var x) + where + [x] = mkTemplateLocals [openAlphaTy] +\end{code} + +@realWorld#@ used to be a magic literal, \tr{void#}. If things get +nasty as-is, change it back to a literal (@Literal@). + +voidArgId is a Local Id used simply as an argument in functions +where we just want an arg to avoid having a thunk of unlifted type. +E.g. + x = \ void :: State# RealWorld -> (# p, q #) + +This comes up in strictness analysis + +\begin{code} +realWorldPrimId -- :: State# RealWorld + = pcMiscPrelId realWorldName realWorldStatePrimTy + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) + -- The evaldUnfolding makes it look that realWorld# is evaluated + -- which in turn makes Simplify.interestingArg return True, + -- which in turn makes INLINE things applied to realWorld# likely + -- to be inlined + +voidArgId -- :: State# RealWorld + = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy +\end{code} + + +%************************************************************************ +%* * +\subsection[PrelVals-error-related]{@error@ and friends; @trace@} +%* * +%************************************************************************ + +GHC randomly injects these into the code. + +@patError@ is just a version of @error@ for pattern-matching +failures. It knows various ``codes'' which expand to longer +strings---this saves space! + +@absentErr@ is a thing we put in for ``absent'' arguments. They jolly +well shouldn't be yanked on, but if one is, then you will get a +friendly message from @absentErr@ (rather than a totally random +crash). + +@parError@ is a special version of @error@ which the compiler does +not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ +templates, but we don't ever expect to generate code for it. + +\begin{code} +mkRuntimeErrorApp + :: Id -- Should be of type (forall a. Addr# -> a) + -- where Addr# points to a UTF8 encoded string + -> Type -- The type to instantiate 'a' + -> String -- The string to print + -> CoreExpr + +mkRuntimeErrorApp err_id res_ty err_msg + = mkApps (Var err_id) [Type res_ty, err_string] + where + err_string = Lit (mkStringLit err_msg) + +rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName +rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName +iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName +rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName +pAT_ERROR_ID = mkRuntimeErrorId patErrorName +nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName +nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName + +-- The runtime error Ids take a UTF8-encoded string as argument +mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy +runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) +\end{code} + +\begin{code} +eRROR_ID = pc_bottoming_Id errorName errorTy + +errorTy :: Type +errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy) + -- Notice the openAlphaTyVar. It says that "error" can be applied + -- to unboxed as well as boxed types. This is OK because it never + -- returns, so the return type is irrelevant. +\end{code} + + +%************************************************************************ +%* * +\subsection{Utilities} +%* * +%************************************************************************ + +\begin{code} +pcMiscPrelId :: Name -> Type -> IdInfo -> Id +pcMiscPrelId name ty info + = mkVanillaGlobal name ty info + -- We lie and say the thing is imported; otherwise, we get into + -- a mess with dependency analysis; e.g., core2stg may heave in + -- random calls to GHCbase.unpackPS__. If GHCbase is the module + -- being compiled, then it's just a matter of luck if the definition + -- will be in "the right place" to be in scope. + +pc_bottoming_Id name ty + = pcMiscPrelId name ty bottoming_info + where + bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig + -- Do *not* mark them as NoCafRefs, because they can indeed have + -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, + -- which has some CAFs + -- In due course we may arrange that these error-y things are + -- regarded by the GC as permanently live, in which case we + -- can give them NoCaf info. As it is, any function that calls + -- any pc_bottoming_Id will itself have CafRefs, which bloats + -- SRTs. + + strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes) + -- These "bottom" out, no matter what their arguments + +(openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars +openAlphaTy = mkTyVarTy openAlphaTyVar +openBetaTy = mkTyVarTy openBetaTyVar +\end{code} + diff --git a/compiler/basicTypes/MkId.lhs-boot b/compiler/basicTypes/MkId.lhs-boot new file mode 100644 index 0000000000..4f9615a061 --- /dev/null +++ b/compiler/basicTypes/MkId.lhs-boot @@ -0,0 +1,9 @@ +\begin{code} +module MkId where +import Name( Name ) +import DataCon( DataCon, DataConIds ) + +mkDataConIds :: Name -> Name -> DataCon -> DataConIds +\end{code} + + diff --git a/compiler/basicTypes/Module.hi-boot-5 b/compiler/basicTypes/Module.hi-boot-5 new file mode 100644 index 0000000000..cdc5fbf581 --- /dev/null +++ b/compiler/basicTypes/Module.hi-boot-5 @@ -0,0 +1,4 @@ +__interface Module 1 0 where +__export Module Module ; +1 data Module ; + diff --git a/compiler/basicTypes/Module.hi-boot-6 b/compiler/basicTypes/Module.hi-boot-6 new file mode 100644 index 0000000000..c4d4b5d474 --- /dev/null +++ b/compiler/basicTypes/Module.hi-boot-6 @@ -0,0 +1,3 @@ +module Module where +data Module + diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs new file mode 100644 index 0000000000..69521625b0 --- /dev/null +++ b/compiler/basicTypes/Module.lhs @@ -0,0 +1,216 @@ +% +% (c) The University of Glasgow, 2004 +% + +Module +~~~~~~~~~~ +Simply the name of a module, represented as a FastString. +These are Uniquable, hence we can build FiniteMaps with ModuleNames as +the keys. + +\begin{code} +module Module + ( + Module -- Abstract, instance of Eq, Ord, Outputable + , pprModule -- :: ModuleName -> SDoc + + , ModLocation(..) + , addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn + + , moduleString -- :: ModuleName -> String + , moduleFS -- :: ModuleName -> FastString + + , mkModule -- :: String -> ModuleName + , mkModuleFS -- :: FastString -> ModuleName + + , ModuleEnv + , elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C + , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv + , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv + , moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv + , extendModuleEnv_C, filterModuleEnv + + , ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet + + ) where + +#include "HsVersions.h" +import Outputable +import Unique ( Uniquable(..) ) +import UniqFM +import UniqSet +import Binary +import FastString +\end{code} + +%************************************************************************ +%* * +\subsection{Module locations} +%* * +%************************************************************************ + +\begin{code} +data ModLocation + = ModLocation { + ml_hs_file :: Maybe FilePath, + -- The source file, if we have one. Package modules + -- probably don't have source files. + + ml_hi_file :: FilePath, + -- Where the .hi file is, whether or not it exists + -- yet. Always of form foo.hi, even if there is an + -- hi-boot file (we add the -boot suffix later) + + ml_obj_file :: FilePath + -- Where the .o file is, whether or not it exists yet. + -- (might not exist either because the module hasn't + -- been compiled yet, or because it is part of a + -- package with a .a file) + } deriving Show + +instance Outputable ModLocation where + ppr = text . show +\end{code} + +For a module in another package, the hs_file and obj_file +components of ModLocation are undefined. + +The locations specified by a ModLocation may or may not +correspond to actual files yet: for example, even if the object +file doesn't exist, the ModLocation still contains the path to +where the object file will reside if/when it is created. + +\begin{code} +addBootSuffix :: FilePath -> FilePath +-- Add the "-boot" suffix to .hs, .hi and .o files +addBootSuffix path = path ++ "-boot" + +addBootSuffix_maybe :: Bool -> FilePath -> FilePath +addBootSuffix_maybe is_boot path + | is_boot = addBootSuffix path + | otherwise = path + +addBootSuffixLocn :: ModLocation -> ModLocation +addBootSuffixLocn locn + = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) + , ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_obj_file = addBootSuffix (ml_obj_file locn) } +\end{code} + + +%************************************************************************ +%* * +\subsection{The name of a module} +%* * +%************************************************************************ + +\begin{code} +newtype Module = Module FastString + -- Haskell module names can include the quote character ', + -- so the module names have the z-encoding applied to them + +instance Binary Module where + put_ bh (Module m) = put_ bh m + get bh = do m <- get bh; return (Module m) + +instance Uniquable Module where + getUnique (Module nm) = getUnique nm + +instance Eq Module where + nm1 == nm2 = getUnique nm1 == getUnique nm2 + +-- Warning: gives an ordering relation based on the uniques of the +-- FastStrings which are the (encoded) module names. This is _not_ +-- a lexicographical ordering. +instance Ord Module where + nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 + +instance Outputable Module where + ppr = pprModule + +pprModule :: Module -> SDoc +pprModule (Module nm) = + getPprStyle $ \ sty -> + if codeStyle sty + then ftext (zEncodeFS nm) + else ftext nm + +moduleFS :: Module -> FastString +moduleFS (Module mod) = mod + +moduleString :: Module -> String +moduleString (Module mod) = unpackFS mod + +-- used to be called mkSrcModule +mkModule :: String -> Module +mkModule s = Module (mkFastString s) + +-- used to be called mkSrcModuleFS +mkModuleFS :: FastString -> Module +mkModuleFS s = Module s +\end{code} + +%************************************************************************ +%* * +\subsection{@ModuleEnv@s} +%* * +%************************************************************************ + +\begin{code} +type ModuleEnv elt = UniqFM elt + +emptyModuleEnv :: ModuleEnv a +mkModuleEnv :: [(Module, a)] -> ModuleEnv a +unitModuleEnv :: Module -> a -> ModuleEnv a +extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnv_C :: (a->a->a) -> ModuleEnv a -> Module -> a -> ModuleEnv a +plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a +extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a + +delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a +delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a +plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a +mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b +moduleEnvElts :: ModuleEnv a -> [a] + +isEmptyModuleEnv :: ModuleEnv a -> Bool +lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a +lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a +elemModuleEnv :: Module -> ModuleEnv a -> Bool +foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b +filterModuleEnv :: (a -> Bool) -> ModuleEnv a -> ModuleEnv a + +filterModuleEnv = filterUFM +elemModuleEnv = elemUFM +extendModuleEnv = addToUFM +extendModuleEnv_C = addToUFM_C +extendModuleEnvList = addListToUFM +plusModuleEnv_C = plusUFM_C +delModuleEnvList = delListFromUFM +delModuleEnv = delFromUFM +plusModuleEnv = plusUFM +lookupModuleEnv = lookupUFM +lookupWithDefaultModuleEnv = lookupWithDefaultUFM +mapModuleEnv = mapUFM +mkModuleEnv = listToUFM +emptyModuleEnv = emptyUFM +moduleEnvElts = eltsUFM +unitModuleEnv = unitUFM +isEmptyModuleEnv = isNullUFM +foldModuleEnv = foldUFM +\end{code} + +\begin{code} +type ModuleSet = UniqSet Module +mkModuleSet :: [Module] -> ModuleSet +extendModuleSet :: ModuleSet -> Module -> ModuleSet +emptyModuleSet :: ModuleSet +moduleSetElts :: ModuleSet -> [Module] +elemModuleSet :: Module -> ModuleSet -> Bool + +emptyModuleSet = emptyUniqSet +mkModuleSet = mkUniqSet +extendModuleSet = addOneToUniqSet +moduleSetElts = uniqSetToList +elemModuleSet = elementOfUniqSet +\end{code} diff --git a/compiler/basicTypes/Module.lhs-boot b/compiler/basicTypes/Module.lhs-boot new file mode 100644 index 0000000000..d75c032d45 --- /dev/null +++ b/compiler/basicTypes/Module.lhs-boot @@ -0,0 +1,6 @@ +\begin{code} +module Module where + +data Module +\end{code} + diff --git a/compiler/basicTypes/Name.hi-boot-5 b/compiler/basicTypes/Name.hi-boot-5 new file mode 100644 index 0000000000..634d95433c --- /dev/null +++ b/compiler/basicTypes/Name.hi-boot-5 @@ -0,0 +1,3 @@ +__interface Name 1 0 where +__export Name Name; +1 data Name ; diff --git a/compiler/basicTypes/Name.hi-boot-6 b/compiler/basicTypes/Name.hi-boot-6 new file mode 100644 index 0000000000..c4eeca4d68 --- /dev/null +++ b/compiler/basicTypes/Name.hi-boot-6 @@ -0,0 +1,3 @@ +module Name where + +data Name diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs new file mode 100644 index 0000000000..1e1fb31f84 --- /dev/null +++ b/compiler/basicTypes/Name.lhs @@ -0,0 +1,384 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[Name]{@Name@: to transmit name info from renamer to typechecker} + +\begin{code} +module Name ( + -- Re-export the OccName stuff + module OccName, + + -- The Name type + Name, -- Abstract + BuiltInSyntax(..), + mkInternalName, mkSystemName, + mkSystemVarName, mkSysTvName, + mkFCallName, mkIPName, + mkExternalName, mkWiredInName, + + nameUnique, setNameUnique, + nameOccName, nameModule, nameModule_maybe, + tidyNameOcc, + hashName, localiseName, + + nameSrcLoc, nameParent, nameParent_maybe, isImplicitName, + + isSystemName, isInternalName, isExternalName, + isTyVarName, isWiredInName, isBuiltInSyntax, + wiredInNameTyThing_maybe, + nameIsLocalOrFrom, + + -- Class NamedThing and overloaded friends + NamedThing(..), + getSrcLoc, getOccString + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} TypeRep( TyThing ) + +import OccName -- All of it +import Module ( Module, moduleFS ) +import SrcLoc ( noSrcLoc, wiredInSrcLoc, SrcLoc ) +import Unique ( Unique, Uniquable(..), getKey, pprUnique ) +import Maybes ( orElse, isJust ) +import FastString ( FastString, zEncodeFS ) +import Outputable +\end{code} + +%************************************************************************ +%* * +\subsection[Name-datatype]{The @Name@ datatype, and name construction} +%* * +%************************************************************************ + +\begin{code} +data Name = Name { + n_sort :: NameSort, -- What sort of name it is + n_occ :: !OccName, -- Its occurrence name + n_uniq :: Unique, + n_loc :: !SrcLoc -- Definition site + } + +-- NOTE: we make the n_loc field strict to eliminate some potential +-- (and real!) space leaks, due to the fact that we don't look at +-- the SrcLoc in a Name all that often. + +data NameSort + = External Module (Maybe Name) + -- (Just parent) => this Name is a subordinate name of 'parent' + -- e.g. data constructor of a data type, method of a class + -- Nothing => not a subordinate + + | WiredIn Module (Maybe Name) TyThing BuiltInSyntax + -- A variant of External, for wired-in things + + | Internal -- A user-defined Id or TyVar + -- defined in the module being compiled + + | System -- A system-defined Id or TyVar. Typically the + -- OccName is very uninformative (like 's') + +data BuiltInSyntax = BuiltInSyntax | UserSyntax +-- BuiltInSyntax is for things like (:), [], tuples etc, +-- which have special syntactic forms. They aren't "in scope" +-- as such. +\end{code} + +Notes about the NameSorts: + +1. Initially, top-level Ids (including locally-defined ones) get External names, + and all other local Ids get Internal names + +2. Things with a External name are given C static labels, so they finally + appear in the .o file's symbol table. They appear in the symbol table + in the form M.n. If originally-local things have this property they + must be made @External@ first. + +3. In the tidy-core phase, a External that is not visible to an importer + is changed to Internal, and a Internal that is visible is changed to External + +4. A System Name differs in the following ways: + a) has unique attached when printing dumps + b) unifier eliminates sys tyvars in favour of user provs where possible + + Before anything gets printed in interface files or output code, it's + fed through a 'tidy' processor, which zaps the OccNames to have + unique names; and converts all sys-locals to user locals + If any desugarer sys-locals have survived that far, they get changed to + "ds1", "ds2", etc. + +Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) + +Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, + not read from an interface file. + E.g. Bool, True, Int, Float, and many others + +All built-in syntax is for wired-in things. + +\begin{code} +nameUnique :: Name -> Unique +nameOccName :: Name -> OccName +nameModule :: Name -> Module +nameSrcLoc :: Name -> SrcLoc + +nameUnique name = n_uniq name +nameOccName name = n_occ name +nameSrcLoc name = n_loc name +\end{code} + +\begin{code} +nameIsLocalOrFrom :: Module -> Name -> Bool +isInternalName :: Name -> Bool +isExternalName :: Name -> Bool +isSystemName :: Name -> Bool +isWiredInName :: Name -> Bool + +isWiredInName (Name {n_sort = WiredIn _ _ _ _}) = True +isWiredInName other = False + +wiredInNameTyThing_maybe :: Name -> Maybe TyThing +wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ _ thing _}) = Just thing +wiredInNameTyThing_maybe other = Nothing + +isBuiltInSyntax (Name {n_sort = WiredIn _ _ _ BuiltInSyntax}) = True +isBuiltInSyntax other = False + +isExternalName (Name {n_sort = External _ _}) = True +isExternalName (Name {n_sort = WiredIn _ _ _ _}) = True +isExternalName other = False + +isInternalName name = not (isExternalName name) + +nameParent_maybe :: Name -> Maybe Name +nameParent_maybe (Name {n_sort = External _ p}) = p +nameParent_maybe (Name {n_sort = WiredIn _ p _ _}) = p +nameParent_maybe other = Nothing + +nameParent :: Name -> Name +nameParent name = case nameParent_maybe name of + Just parent -> parent + Nothing -> name + +isImplicitName :: Name -> Bool +-- An Implicit Name is one has a parent; that is, one whose definition +-- derives from the parent thing +isImplicitName name = isJust (nameParent_maybe name) + +nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) +nameModule_maybe (Name { n_sort = External mod _}) = Just mod +nameModule_maybe (Name { n_sort = WiredIn mod _ _ _}) = Just mod +nameModule_maybe name = Nothing + +nameIsLocalOrFrom from name + | isExternalName name = from == nameModule name + | otherwise = True + +isTyVarName :: Name -> Bool +isTyVarName name = isTvOcc (nameOccName name) + +isSystemName (Name {n_sort = System}) = True +isSystemName other = False +\end{code} + + +%************************************************************************ +%* * +\subsection{Making names} +%* * +%************************************************************************ + +\begin{code} +mkInternalName :: Unique -> OccName -> SrcLoc -> Name +mkInternalName uniq occ loc = Name { n_uniq = uniq, n_sort = Internal, n_occ = occ, n_loc = loc } + -- NB: You might worry that after lots of huffing and + -- puffing we might end up with two local names with distinct + -- uniques, but the same OccName. Indeed we can, but that's ok + -- * the insides of the compiler don't care: they use the Unique + -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the + -- uniques if you get confused + -- * for interface files we tidyCore first, which puts the uniques + -- into the print name (see setNameVisibility below) + +mkExternalName :: Unique -> Module -> OccName -> Maybe Name -> SrcLoc -> Name +mkExternalName uniq mod occ mb_parent loc + = Name { n_uniq = uniq, n_sort = External mod mb_parent, + n_occ = occ, n_loc = loc } + +mkWiredInName :: Module -> OccName -> Unique + -> Maybe Name -> TyThing -> BuiltInSyntax -> Name +mkWiredInName mod occ uniq mb_parent thing built_in + = Name { n_uniq = uniq, + n_sort = WiredIn mod mb_parent thing built_in, + n_occ = occ, n_loc = wiredInSrcLoc } + +mkSystemName :: Unique -> OccName -> Name +mkSystemName uniq occ = Name { n_uniq = uniq, n_sort = System, + n_occ = occ, n_loc = noSrcLoc } + +mkSystemVarName :: Unique -> FastString -> Name +mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) + +mkSysTvName :: Unique -> FastString -> Name +mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs) + +mkFCallName :: Unique -> String -> Name + -- The encoded string completely describes the ccall +mkFCallName uniq str = Name { n_uniq = uniq, n_sort = Internal, + n_occ = mkVarOcc str, n_loc = noSrcLoc } + +mkIPName :: Unique -> OccName -> Name +mkIPName uniq occ + = Name { n_uniq = uniq, + n_sort = Internal, + n_occ = occ, + n_loc = noSrcLoc } +\end{code} + +\begin{code} +-- When we renumber/rename things, we need to be +-- able to change a Name's Unique to match the cached +-- one in the thing it's the name of. If you know what I mean. +setNameUnique name uniq = name {n_uniq = uniq} + +tidyNameOcc :: Name -> OccName -> Name +-- We set the OccName of a Name when tidying +-- In doing so, we change System --> Internal, so that when we print +-- it we don't get the unique by default. It's tidy now! +tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} +tidyNameOcc name occ = name { n_occ = occ } + +localiseName :: Name -> Name +localiseName n = n { n_sort = Internal } +\end{code} + + +%************************************************************************ +%* * +\subsection{Predicates and selectors} +%* * +%************************************************************************ + +\begin{code} +hashName :: Name -> Int +hashName name = getKey (nameUnique name) +\end{code} + + +%************************************************************************ +%* * +\subsection[Name-instances]{Instance declarations} +%* * +%************************************************************************ + +\begin{code} +cmpName n1 n2 = n_uniq n1 `compare` n_uniq n2 +\end{code} + +\begin{code} +instance Eq Name where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +instance Ord Name where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpName a b + +instance Uniquable Name where + getUnique = nameUnique + +instance NamedThing Name where + getName n = n +\end{code} + + +%************************************************************************ +%* * +\subsection{Pretty printing} +%* * +%************************************************************************ + +\begin{code} +instance Outputable Name where + ppr name = pprName name + +instance OutputableBndr Name where + pprBndr _ name = pprName name + +pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) + = getPprStyle $ \ sty -> + case sort of + WiredIn mod _ _ builtin -> pprExternal sty uniq mod occ True builtin + External mod _ -> pprExternal sty uniq mod occ False UserSyntax + System -> pprSystem sty uniq occ + Internal -> pprInternal sty uniq occ + +pprExternal sty uniq mod occ is_wired is_builtin + | codeStyle sty = ppr_z_module mod <> char '_' <> ppr_z_occ_name occ + -- In code style, always qualify + -- ToDo: maybe we could print all wired-in things unqualified + -- in code style, to reduce symbol table bloat? + | debugStyle sty = ppr mod <> dot <> ppr_occ_name occ + <> braces (hsep [if is_wired then ptext SLIT("(w)") else empty, + pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | BuiltInSyntax <- is_builtin = ppr_occ_name occ + -- never qualify builtin syntax + | unqualStyle sty mod occ = ppr_occ_name occ + | otherwise = ppr mod <> dot <> ppr_occ_name occ + +pprInternal sty uniq occ + | codeStyle sty = pprUnique uniq + | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | dumpStyle sty = ppr_occ_name occ <> char '_' <> pprUnique uniq + -- For debug dumps, we're not necessarily dumping + -- tidied code, so we need to print the uniques. + | otherwise = ppr_occ_name occ -- User style + +-- Like Internal, except that we only omit the unique in Iface style +pprSystem sty uniq occ + | codeStyle sty = pprUnique uniq + | debugStyle sty = ppr_occ_name occ <> char '_' <> pprUnique uniq + <> braces (pprNameSpaceBrief (occNameSpace occ)) + | otherwise = ppr_occ_name occ <> char '_' <> pprUnique uniq + -- If the tidy phase hasn't run, the OccName + -- is unlikely to be informative (like 's'), + -- so print the unique + +ppr_occ_name occ = ftext (occNameFS occ) + -- Don't use pprOccName; instead, just print the string of the OccName; + -- we print the namespace in the debug stuff above + +-- In code style, we Z-encode the strings. The results of Z-encoding each FastString are +-- cached behind the scenes in the FastString implementation. +ppr_z_occ_name occ = ftext (zEncodeFS (occNameFS occ)) +ppr_z_module mod = ftext (zEncodeFS (moduleFS mod)) + +\end{code} + +%************************************************************************ +%* * +\subsection{Overloaded functions related to Names} +%* * +%************************************************************************ + +\begin{code} +class NamedThing a where + getOccName :: a -> OccName + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method +\end{code} + +\begin{code} +getSrcLoc :: NamedThing a => a -> SrcLoc +getOccString :: NamedThing a => a -> String + +getSrcLoc = nameSrcLoc . getName +getOccString = occNameString . getOccName +\end{code} + diff --git a/compiler/basicTypes/Name.lhs-boot b/compiler/basicTypes/Name.lhs-boot new file mode 100644 index 0000000000..167ce4242d --- /dev/null +++ b/compiler/basicTypes/Name.lhs-boot @@ -0,0 +1,5 @@ +\begin{code} +module Name where + +data Name +\end{code} diff --git a/compiler/basicTypes/NameEnv.lhs b/compiler/basicTypes/NameEnv.lhs new file mode 100644 index 0000000000..ff637010aa --- /dev/null +++ b/compiler/basicTypes/NameEnv.lhs @@ -0,0 +1,72 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[NameEnv]{@NameEnv@: name environments} + +\begin{code} +module NameEnv ( + NameEnv, mkNameEnv, + emptyNameEnv, unitNameEnv, nameEnvElts, + extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList, + foldNameEnv, filterNameEnv, + plusNameEnv, plusNameEnv_C, + lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, + elemNameEnv, mapNameEnv + ) where + +#include "HsVersions.h" + +import Name ( Name ) +import UniqFM +import Maybes ( expectJust ) +\end{code} + +%************************************************************************ +%* * +\subsection{Name environment} +%* * +%************************************************************************ + +\begin{code} +type NameEnv a = UniqFM a -- Domain is Name + +emptyNameEnv :: NameEnv a +mkNameEnv :: [(Name,a)] -> NameEnv a +nameEnvElts :: NameEnv a -> [a] +extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b +extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool +unitNameEnv :: Name -> a -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +lookupNameEnv_NF :: NameEnv a -> Name -> a +foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b +filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt +mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 + +emptyNameEnv = emptyUFM +foldNameEnv = foldUFM +mkNameEnv = listToUFM +nameEnvElts = eltsUFM +extendNameEnv_C = addToUFM_C +extendNameEnv_Acc = addToUFM_Acc +extendNameEnv = addToUFM +plusNameEnv = plusUFM +plusNameEnv_C = plusUFM_C +extendNameEnvList = addListToUFM +delFromNameEnv = delFromUFM +delListFromNameEnv = delListFromUFM +elemNameEnv = elemUFM +unitNameEnv = unitUFM +filterNameEnv = filterUFM +mapNameEnv = mapUFM + +lookupNameEnv = lookupUFM +lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupUFM env n) +\end{code} + diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs new file mode 100644 index 0000000000..d0e55dec68 --- /dev/null +++ b/compiler/basicTypes/NameSet.lhs @@ -0,0 +1,190 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1998 +% +\section[NameSet]{@NameSets@} + +\begin{code} +module NameSet ( + -- Sets of Names + NameSet, + emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, + minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, + delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet, + intersectsNameSet, intersectNameSet, + + -- Free variables + FreeVars, isEmptyFVs, emptyFVs, plusFVs, plusFV, + mkFVs, addOneFV, unitFV, delFV, delFVs, + + -- Defs and uses + Defs, Uses, DefUse, DefUses, + emptyDUs, usesOnly, mkDUs, plusDU, + findUses, duDefs, duUses, allUses + ) where + +#include "HsVersions.h" + +import Name +import UniqSet +\end{code} + + +%************************************************************************ +%* * +\subsection[Sets of names} +%* * +%************************************************************************ + +\begin{code} +type NameSet = UniqSet Name +emptyNameSet :: NameSet +unitNameSet :: Name -> NameSet +addListToNameSet :: NameSet -> [Name] -> NameSet +addOneToNameSet :: NameSet -> Name -> NameSet +mkNameSet :: [Name] -> NameSet +unionNameSets :: NameSet -> NameSet -> NameSet +unionManyNameSets :: [NameSet] -> NameSet +minusNameSet :: NameSet -> NameSet -> NameSet +elemNameSet :: Name -> NameSet -> Bool +nameSetToList :: NameSet -> [Name] +isEmptyNameSet :: NameSet -> Bool +delFromNameSet :: NameSet -> Name -> NameSet +delListFromNameSet :: NameSet -> [Name] -> NameSet +foldNameSet :: (Name -> b -> b) -> b -> NameSet -> b +filterNameSet :: (Name -> Bool) -> NameSet -> NameSet +intersectNameSet :: NameSet -> NameSet -> NameSet +intersectsNameSet :: NameSet -> NameSet -> Bool -- True if non-empty intersection + -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty + +isEmptyNameSet = isEmptyUniqSet +emptyNameSet = emptyUniqSet +unitNameSet = unitUniqSet +mkNameSet = mkUniqSet +addListToNameSet = addListToUniqSet +addOneToNameSet = addOneToUniqSet +unionNameSets = unionUniqSets +unionManyNameSets = unionManyUniqSets +minusNameSet = minusUniqSet +elemNameSet = elementOfUniqSet +nameSetToList = uniqSetToList +delFromNameSet = delOneFromUniqSet +foldNameSet = foldUniqSet +filterNameSet = filterUniqSet +intersectNameSet = intersectUniqSets + +delListFromNameSet set ns = foldl delFromNameSet set ns + +intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2)) +\end{code} + + +%************************************************************************ +%* * +\subsection{Free variables} +%* * +%************************************************************************ + +These synonyms are useful when we are thinking of free variables + +\begin{code} +type FreeVars = NameSet + +plusFV :: FreeVars -> FreeVars -> FreeVars +addOneFV :: FreeVars -> Name -> FreeVars +unitFV :: Name -> FreeVars +emptyFVs :: FreeVars +plusFVs :: [FreeVars] -> FreeVars +mkFVs :: [Name] -> FreeVars +delFV :: Name -> FreeVars -> FreeVars +delFVs :: [Name] -> FreeVars -> FreeVars + +isEmptyFVs = isEmptyNameSet +emptyFVs = emptyNameSet +plusFVs = unionManyNameSets +plusFV = unionNameSets +mkFVs = mkNameSet +addOneFV = addOneToNameSet +unitFV = unitNameSet +delFV n s = delFromNameSet s n +delFVs ns s = delListFromNameSet s ns +\end{code} + + +%************************************************************************ +%* * + Defs and uses +%* * +%************************************************************************ + +\begin{code} +type Defs = NameSet +type Uses = NameSet + +type DefUses = [DefUse] + -- In dependency order: earlier Defs scope over later Uses + +type DefUse = (Maybe Defs, Uses) + -- For items (Just ds, us), the use of any member + -- of the ds implies that all the us are used too + -- + -- Also, us may mention ds + -- + -- Nothing => Nothing defined in this group, but + -- nevertheless all the uses are essential. + -- Used for instance declarations, for example + +emptyDUs :: DefUses +emptyDUs = [] + +usesOnly :: Uses -> DefUses +usesOnly uses = [(Nothing, uses)] + +mkDUs :: [(Defs,Uses)] -> DefUses +mkDUs pairs = [(Just defs, uses) | (defs,uses) <- pairs] + +plusDU :: DefUses -> DefUses -> DefUses +plusDU = (++) + +duDefs :: DefUses -> Defs +duDefs dus = foldr get emptyNameSet dus + where + get (Nothing, u1) d2 = d2 + get (Just d1, u1) d2 = d1 `unionNameSets` d2 + +duUses :: DefUses -> Uses +-- Just like allUses, but defs are not eliminated +duUses dus = foldr get emptyNameSet dus + where + get (d1, u1) u2 = u1 `unionNameSets` u2 + +allUses :: DefUses -> Uses +-- Collect all uses, regardless of +-- whether the group is itself used, +-- but remove defs on the way +allUses dus + = foldr get emptyNameSet dus + where + get (Nothing, rhs_uses) uses = rhs_uses `unionNameSets` uses + get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSets` uses) + `minusNameSet` defs + +findUses :: DefUses -> Uses -> Uses +-- Given some DefUses and some Uses, +-- find all the uses, transitively. +-- The result is a superset of the input uses; +-- and includes things defined in the input DefUses +-- (but only if they are used) +findUses dus uses + = foldr get uses dus + where + get (Nothing, rhs_uses) uses + = rhs_uses `unionNameSets` uses + get (Just defs, rhs_uses) uses + | defs `intersectsNameSet` uses -- Used + || not (all (reportIfUnused . nameOccName) (nameSetToList defs)) + -- At least one starts with an "_", + -- so treat the group as used + = rhs_uses `unionNameSets` uses + | otherwise -- No def is used + = uses +\end{code}
\ No newline at end of file diff --git a/compiler/basicTypes/NewDemand.lhs b/compiler/basicTypes/NewDemand.lhs new file mode 100644 index 0000000000..8e68fd87d2 --- /dev/null +++ b/compiler/basicTypes/NewDemand.lhs @@ -0,0 +1,318 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[Demand]{@Demand@: the amount of demand on a value} + +\begin{code} +module NewDemand( + Demand(..), + topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd, + isTop, isAbsent, seqDemand, + + DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, + dmdTypeDepth, seqDmdType, + DmdEnv, emptyDmdEnv, + DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd, + + Demands(..), mapDmds, zipWithDmds, allTop, seqDemands, + + StrictSig(..), mkStrictSig, topSig, botSig, cprSig, + isTopSig, + splitStrictSig, + pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig, + ) where + +#include "HsVersions.h" + +import StaticFlags ( opt_CprOff ) +import BasicTypes ( Arity ) +import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv ) +import UniqFM ( ufmToList ) +import Util ( listLengthCmp, zipWithEqual ) +import Outputable +\end{code} + + +%************************************************************************ +%* * +\subsection{Demands} +%* * +%************************************************************************ + +\begin{code} +data Demand + = Top -- T; used for unlifted types too, so that + -- A `lub` T = T + | Abs -- A + + | Call Demand -- C(d) + + | Eval Demands -- U(ds) + + | Defer Demands -- D(ds) + + | Box Demand -- B(d) + + | Bot -- B + deriving( Eq ) + -- Equality needed for fixpoints in DmdAnal + +data Demands = Poly Demand -- Polymorphic case + | Prod [Demand] -- Product case + deriving( Eq ) + +allTop (Poly d) = isTop d +allTop (Prod ds) = all isTop ds + +isTop Top = True +isTop d = False + +isAbsent Abs = True +isAbsent d = False + +mapDmds :: (Demand -> Demand) -> Demands -> Demands +mapDmds f (Poly d) = Poly (f d) +mapDmds f (Prod ds) = Prod (map f ds) + +zipWithDmds :: (Demand -> Demand -> Demand) + -> Demands -> Demands -> Demands +zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2) +zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1] +zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2] +zipWithDmds f (Prod ds1) (Prod ds2) = Prod (zipWithEqual "zipWithDmds" f ds1 ds2) + +topDmd, lazyDmd, seqDmd :: Demand +topDmd = Top -- The most uninformative demand +lazyDmd = Box Abs +seqDmd = Eval (Poly Abs) -- Polymorphic seq demand +evalDmd = Box seqDmd -- Evaluate and return +errDmd = Box Bot -- This used to be called X + +isStrictDmd :: Demand -> Bool +isStrictDmd Bot = True +isStrictDmd (Eval _) = True +isStrictDmd (Call _) = True +isStrictDmd (Box d) = isStrictDmd d +isStrictDmd other = False + +seqDemand :: Demand -> () +seqDemand (Call d) = seqDemand d +seqDemand (Eval ds) = seqDemands ds +seqDemand (Defer ds) = seqDemands ds +seqDemand (Box d) = seqDemand d +seqDemand _ = () + +seqDemands :: Demands -> () +seqDemands (Poly d) = seqDemand d +seqDemands (Prod ds) = seqDemandList ds + +seqDemandList :: [Demand] -> () +seqDemandList [] = () +seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds + +instance Outputable Demand where + ppr Top = char 'T' + ppr Abs = char 'A' + ppr Bot = char 'B' + + ppr (Defer ds) = char 'D' <> ppr ds + ppr (Eval ds) = char 'U' <> ppr ds + + ppr (Box (Eval ds)) = char 'S' <> ppr ds + ppr (Box Abs) = char 'L' + ppr (Box Bot) = char 'X' + + ppr (Call d) = char 'C' <> parens (ppr d) + + +instance Outputable Demands where + ppr (Poly Abs) = empty + ppr (Poly d) = parens (ppr d <> char '*') + ppr (Prod ds) = parens (hcat (map ppr ds)) + -- At one time I printed U(AAA) as U, but that + -- confuses (Poly Abs) with (Prod AAA), and the + -- worker/wrapper generation differs slightly for these two + -- [Reason: in the latter case we can avoid passing the arg; + -- see notes with WwLib.mkWWstr_one.] +\end{code} + + +%************************************************************************ +%* * +\subsection{Demand types} +%* * +%************************************************************************ + +\begin{code} +data DmdType = DmdType + DmdEnv -- Demand on explicitly-mentioned + -- free variables + [Demand] -- Demand on arguments + DmdResult -- Nature of result + + -- IMPORTANT INVARIANT + -- The default demand on free variables not in the DmdEnv is: + -- DmdResult = BotRes <=> Bot + -- DmdResult = TopRes/ResCPR <=> Abs + + -- ANOTHER IMPORTANT INVARIANT + -- The Demands in the argument list are never + -- Bot, Defer d + -- Handwavey reason: these don't correspond to calling conventions + -- See DmdAnal.funArgDemand for details + + +-- This guy lets us switch off CPR analysis +-- by making sure that everything uses TopRes instead of RetCPR +-- Assuming, of course, that they don't mention RetCPR by name. +-- They should onlyu use retCPR +retCPR | opt_CprOff = TopRes + | otherwise = RetCPR + +seqDmdType (DmdType env ds res) = + {- ??? env `seq` -} seqDemandList ds `seq` res `seq` () + +type DmdEnv = VarEnv Demand + +data DmdResult = TopRes -- Nothing known + | RetCPR -- Returns a constructed product + | BotRes -- Diverges or errors + deriving( Eq, Show ) + -- Equality for fixpoints + -- Show needed for Show in Lex.Token (sigh) + +-- Equality needed for fixpoints in DmdAnal +instance Eq DmdType where + (==) (DmdType fv1 ds1 res1) + (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2 + && ds1 == ds2 && res1 == res2 + +instance Outputable DmdType where + ppr (DmdType fv ds res) + = hsep [text "DmdType", + hcat (map ppr ds) <> ppr res, + if null fv_elts then empty + else braces (fsep (map pp_elt fv_elts))] + where + pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd + fv_elts = ufmToList fv + +instance Outputable DmdResult where + ppr TopRes = empty -- Keep these distinct from Demand letters + ppr RetCPR = char 'm' -- so that we can print strictness sigs as + ppr BotRes = char 'b' -- dddr + -- without ambiguity + +emptyDmdEnv = emptyVarEnv + +topDmdType = DmdType emptyDmdEnv [] TopRes +botDmdType = DmdType emptyDmdEnv [] BotRes +cprDmdType = DmdType emptyVarEnv [] retCPR + +isTopDmdType :: DmdType -> Bool +-- Only used on top-level types, hence the assert +isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True +isTopDmdType other = False + +isBotRes :: DmdResult -> Bool +isBotRes BotRes = True +isBotRes other = False + +resTypeArgDmd :: DmdResult -> Demand +-- TopRes and BotRes are polymorphic, so that +-- BotRes = Bot -> BotRes +-- TopRes = Top -> TopRes +-- This function makes that concrete +-- We can get a RetCPR, because of the way in which we are (now) +-- giving CPR info to strict arguments. On the first pass, when +-- nothing has demand info, we optimistically give CPR info or RetCPR to all args +resTypeArgDmd TopRes = Top +resTypeArgDmd RetCPR = Top +resTypeArgDmd BotRes = Bot + +returnsCPR :: DmdResult -> Bool +returnsCPR RetCPR = True +returnsCPR other = False + +mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType +mkDmdType fv ds res = DmdType fv ds res + +mkTopDmdType :: [Demand] -> DmdResult -> DmdType +mkTopDmdType ds res = DmdType emptyDmdEnv ds res + +dmdTypeDepth :: DmdType -> Arity +dmdTypeDepth (DmdType _ ds _) = length ds +\end{code} + + +%************************************************************************ +%* * +\subsection{Strictness signature +%* * +%************************************************************************ + +In a let-bound Id we record its strictness info. +In principle, this strictness info is a demand transformer, mapping +a demand on the Id into a DmdType, which gives + a) the free vars of the Id's value + b) the Id's arguments + c) an indication of the result of applying + the Id to its arguments + +However, in fact we store in the Id an extremely emascuated demand transfomer, +namely + a single DmdType +(Nevertheless we dignify StrictSig as a distinct type.) + +This DmdType gives the demands unleashed by the Id when it is applied +to as many arguments as are given in by the arg demands in the DmdType. + +For example, the demand transformer described by the DmdType + DmdType {x -> U(LL)} [V,A] Top +says that when the function is applied to two arguments, it +unleashes demand U(LL) on the free var x, V on the first arg, +and A on the second. + +If this same function is applied to one arg, all we can say is +that it uses x with U*(LL), and its arg with demand L. + +\begin{code} +newtype StrictSig = StrictSig DmdType + deriving( Eq ) + +instance Outputable StrictSig where + ppr (StrictSig ty) = ppr ty + +instance Show StrictSig where + show (StrictSig ty) = showSDoc (ppr ty) + +mkStrictSig :: DmdType -> StrictSig +mkStrictSig dmd_ty = StrictSig dmd_ty + +splitStrictSig :: StrictSig -> ([Demand], DmdResult) +splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) + +isTopSig (StrictSig ty) = isTopDmdType ty + +topSig, botSig, cprSig :: StrictSig +topSig = StrictSig topDmdType +botSig = StrictSig botDmdType +cprSig = StrictSig cprDmdType + + +-- appIsBottom returns true if an application to n args would diverge +appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT +appIsBottom _ _ = False + +isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True +isBottomingSig _ = False + +seqStrictSig (StrictSig ty) = seqDmdType ty + +pprIfaceStrictSig :: StrictSig -> SDoc +-- Used for printing top-level strictness pragmas in interface files +pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) + = hcat (map ppr dmds) <> ppr res +\end{code} + + diff --git a/compiler/basicTypes/OccName.hi-boot-6 b/compiler/basicTypes/OccName.hi-boot-6 new file mode 100644 index 0000000000..705f9b1bd0 --- /dev/null +++ b/compiler/basicTypes/OccName.hi-boot-6 @@ -0,0 +1,4 @@ +module OccName where + +data OccName + diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs new file mode 100644 index 0000000000..a3661a9ab0 --- /dev/null +++ b/compiler/basicTypes/OccName.lhs @@ -0,0 +1,676 @@ +{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +\section[OccName]{@OccName@} + +\begin{code} +module OccName ( + -- * The NameSpace type; abstact + NameSpace, tcName, clsName, tcClsName, dataName, varName, + tvName, srcDataName, + + -- ** Printing + pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, + + -- * The OccName type + OccName, -- Abstract, instance of Outputable + pprOccName, + + -- ** Construction + mkOccName, mkOccNameFS, + mkVarOcc, mkVarOccFS, + mkTyVarOcc, + mkDFunOcc, + mkTupleOcc, + setOccNameSpace, + + -- ** Derived OccNames + mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, + mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, + mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, + mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, + + -- ** Deconstruction + occNameFS, occNameString, occNameSpace, + + isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, + parenSymOcc, reportIfUnused, isTcClsName, isVarName, + + isTupleOcc_maybe, + + -- The OccEnv type + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, + lookupOccEnv, mkOccEnv, extendOccEnvList, elemOccEnv, + occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, + + -- The OccSet type + OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, + extendOccSetList, + unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts, + foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, + + -- Tidying up + TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv, + + -- The basic form of names + isLexCon, isLexVar, isLexId, isLexSym, + isLexConId, isLexConSym, isLexVarId, isLexVarSym, + startsVarSym, startsVarId, startsConSym, startsConId + ) where + +#include "HsVersions.h" + +import Util ( thenCmp ) +import Unique ( Unique, mkUnique, Uniquable(..) ) +import BasicTypes ( Boxity(..), Arity ) +import StaticFlags ( opt_PprStyle_Debug ) +import UniqFM +import UniqSet +import FastString +import Outputable +import Binary + +import GLAEXTS + +import Data.Char ( isUpper, isLower, ord ) + +-- Unicode TODO: put isSymbol in libcompat +#if __GLASGOW_HASKELL__ > 604 +import Data.Char ( isSymbol ) +#else +isSymbol = const False +#endif + +\end{code} + +%************************************************************************ +%* * +\subsection{Name space} +%* * +%************************************************************************ + +\begin{code} +data NameSpace = VarName -- Variables, including "source" data constructors + | DataName -- "Real" data constructors + | TvName -- Type variables + | TcClsName -- Type constructors and classes; Haskell has them + -- in the same name space for now. + deriving( Eq, Ord ) + {-! derive: Binary !-} + +-- Note [Data Constructors] +-- see also: Note [Data Constructor Naming] in DataCon.lhs +-- +-- "Source" data constructors are the data constructors mentioned +-- in Haskell source code +-- +-- "Real" data constructors are the data constructors of the +-- representation type, which may not be the same as the source +-- type + +-- Example: +-- data T = T !(Int,Int) +-- +-- The source datacon has type (Int,Int) -> T +-- The real datacon has type Int -> Int -> T +-- GHC chooses a representation based on the strictness etc. + + +-- Though type constructors and classes are in the same name space now, +-- the NameSpace type is abstract, so we can easily separate them later +tcName = TcClsName -- Type constructors +clsName = TcClsName -- Classes +tcClsName = TcClsName -- Not sure which! + +dataName = DataName +srcDataName = DataName -- Haskell-source data constructors should be + -- in the Data name space + +tvName = TvName +varName = VarName + +isTcClsName :: NameSpace -> Bool +isTcClsName TcClsName = True +isTcClsName _ = False + +isVarName :: NameSpace -> Bool -- Variables or type variables, but not constructors +isVarName TvName = True +isVarName VarName = True +isVarName other = False + +pprNameSpace :: NameSpace -> SDoc +pprNameSpace DataName = ptext SLIT("data constructor") +pprNameSpace VarName = ptext SLIT("variable") +pprNameSpace TvName = ptext SLIT("type variable") +pprNameSpace TcClsName = ptext SLIT("type constructor or class") + +pprNonVarNameSpace :: NameSpace -> SDoc +pprNonVarNameSpace VarName = empty +pprNonVarNameSpace ns = pprNameSpace ns + +pprNameSpaceBrief DataName = char 'd' +pprNameSpaceBrief VarName = char 'v' +pprNameSpaceBrief TvName = ptext SLIT("tv") +pprNameSpaceBrief TcClsName = ptext SLIT("tc") +\end{code} + + +%************************************************************************ +%* * +\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} +%* * +%************************************************************************ + +\begin{code} +data OccName = OccName + { occNameSpace :: !NameSpace + , occNameFS :: !FastString + } +\end{code} + + +\begin{code} +instance Eq OccName where + (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 + +instance Ord OccName where + compare (OccName sp1 s1) (OccName sp2 s2) = (s1 `compare` s2) `thenCmp` + (sp1 `compare` sp2) +\end{code} + + +%************************************************************************ +%* * +\subsection{Printing} +%* * +%************************************************************************ + +\begin{code} +instance Outputable OccName where + ppr = pprOccName + +pprOccName :: OccName -> SDoc +pprOccName (OccName sp occ) + = getPprStyle $ \ sty -> + if codeStyle sty + then ftext (zEncodeFS occ) + else ftext occ <> if debugStyle sty + then braces (pprNameSpaceBrief sp) + else empty +\end{code} + + +%************************************************************************ +%* * +\subsection{Construction} +%* * +%************************************************************************ + +\begin{code} +mkOccName :: NameSpace -> String -> OccName +mkOccName occ_sp str = OccName occ_sp (mkFastString str) + +mkOccNameFS :: NameSpace -> FastString -> OccName +mkOccNameFS occ_sp fs = OccName occ_sp fs + +mkVarOcc :: String -> OccName +mkVarOcc s = mkOccName varName s + +mkVarOccFS :: FastString -> OccName +mkVarOccFS fs = mkOccNameFS varName fs + +mkTyVarOcc :: FastString -> OccName +mkTyVarOcc fs = mkOccNameFS tvName fs +\end{code} + + +%************************************************************************ +%* * + Environments +%* * +%************************************************************************ + +OccEnvs are used mainly for the envts in ModIfaces. + +They are efficient, because FastStrings have unique Int# keys. We assume +this key is less than 2^24, so we can make a Unique using + mkUnique ns key :: Unique +where 'ns' is a Char reprsenting the name space. This in turn makes it +easy to build an OccEnv. + +\begin{code} +instance Uniquable OccName where + getUnique (OccName ns fs) + = mkUnique char (I# (uniqueOfFS fs)) + where -- See notes above about this getUnique function + char = case ns of + VarName -> 'i' + DataName -> 'd' + TvName -> 'v' + TcClsName -> 't' + +type OccEnv a = UniqFM a + +emptyOccEnv :: OccEnv a +unitOccEnv :: OccName -> a -> OccEnv a +extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a +extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a +lookupOccEnv :: OccEnv a -> OccName -> Maybe a +mkOccEnv :: [(OccName,a)] -> OccEnv a +elemOccEnv :: OccName -> OccEnv a -> Bool +foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +occEnvElts :: OccEnv a -> [a] +extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a +plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a +mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b + +emptyOccEnv = emptyUFM +unitOccEnv = unitUFM +extendOccEnv = addToUFM +extendOccEnvList = addListToUFM +lookupOccEnv = lookupUFM +mkOccEnv = listToUFM +elemOccEnv = elemUFM +foldOccEnv = foldUFM +occEnvElts = eltsUFM +plusOccEnv = plusUFM +plusOccEnv_C = plusUFM_C +extendOccEnv_C = addToUFM_C +mapOccEnv = mapUFM + +type OccSet = UniqFM OccName + +emptyOccSet :: OccSet +unitOccSet :: OccName -> OccSet +mkOccSet :: [OccName] -> OccSet +extendOccSet :: OccSet -> OccName -> OccSet +extendOccSetList :: OccSet -> [OccName] -> OccSet +unionOccSets :: OccSet -> OccSet -> OccSet +unionManyOccSets :: [OccSet] -> OccSet +minusOccSet :: OccSet -> OccSet -> OccSet +elemOccSet :: OccName -> OccSet -> Bool +occSetElts :: OccSet -> [OccName] +foldOccSet :: (OccName -> b -> b) -> b -> OccSet -> b +isEmptyOccSet :: OccSet -> Bool +intersectOccSet :: OccSet -> OccSet -> OccSet +intersectsOccSet :: OccSet -> OccSet -> Bool + +emptyOccSet = emptyUniqSet +unitOccSet = unitUniqSet +mkOccSet = mkUniqSet +extendOccSet = addOneToUniqSet +extendOccSetList = addListToUniqSet +unionOccSets = unionUniqSets +unionManyOccSets = unionManyUniqSets +minusOccSet = minusUniqSet +elemOccSet = elementOfUniqSet +occSetElts = uniqSetToList +foldOccSet = foldUniqSet +isEmptyOccSet = isEmptyUniqSet +intersectOccSet = intersectUniqSets +intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) +\end{code} + + +%************************************************************************ +%* * +\subsection{Predicates and taking them apart} +%* * +%************************************************************************ + +\begin{code} +occNameString :: OccName -> String +occNameString (OccName _ s) = unpackFS s + +setOccNameSpace :: NameSpace -> OccName -> OccName +setOccNameSpace sp (OccName _ occ) = OccName sp occ + +isVarOcc, isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool + +isVarOcc (OccName VarName _) = True +isVarOcc other = False + +isTvOcc (OccName TvName _) = True +isTvOcc other = False + +isTcOcc (OccName TcClsName _) = True +isTcOcc other = False + +isValOcc (OccName VarName _) = True +isValOcc (OccName DataName _) = True +isValOcc other = False + +-- Data constructor operator (starts with ':', or '[]') +-- Pretty inefficient! +isDataSymOcc (OccName DataName s) = isLexConSym s +isDataSymOcc (OccName VarName s) + | isLexConSym s = pprPanic "isDataSymOcc: check me" (ppr s) + -- Jan06: I don't think this should happen +isDataSymOcc other = False + +isDataOcc (OccName DataName _) = True +isDataOcc (OccName VarName s) + | isLexCon s = pprPanic "isDataOcc: check me" (ppr s) + -- Jan06: I don't think this should happen +isDataOcc other = False + +-- Any operator (data constructor or variable) +-- Pretty inefficient! +isSymOcc (OccName DataName s) = isLexConSym s +isSymOcc (OccName TcClsName s) = isLexConSym s +isSymOcc (OccName VarName s) = isLexSym s +isSymOcc other = False + +parenSymOcc :: OccName -> SDoc -> SDoc +-- Wrap parens around an operator +parenSymOcc occ doc | isSymOcc occ = parens doc + | otherwise = doc +\end{code} + + +\begin{code} +reportIfUnused :: OccName -> Bool + -- Haskell 98 encourages compilers to suppress warnings about + -- unused names in a pattern if they start with "_". +reportIfUnused occ = case occNameString occ of + ('_' : _) -> False + _other -> True +\end{code} + + +%************************************************************************ +%* * +\subsection{Making system names} +%* * +%************************************************************************ + +Here's our convention for splitting up the interface file name space: + + d... dictionary identifiers + (local variables, so no name-clash worries) + + $f... dict-fun identifiers (from inst decls) + $dm... default methods + $p... superclass selectors + $w... workers + :T... compiler-generated tycons for dictionaries + :D... ...ditto data cons + $sf.. specialised version of f + + in encoded form these appear as Zdfxxx etc + + :... keywords (export:, letrec: etc.) +--- I THINK THIS IS WRONG! + +This knowledge is encoded in the following functions. + + +@mk_deriv@ generates an @OccName@ from the prefix and a string. +NB: The string must already be encoded! + +\begin{code} +mk_deriv :: NameSpace + -> String -- Distinguishes one sort of derived name from another + -> String + -> OccName + +mk_deriv occ_sp sys_prefix str = mkOccName occ_sp (sys_prefix ++ str) +\end{code} + +\begin{code} +mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, + mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, + mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc + :: OccName -> OccName + +-- These derived variables have a prefix that no Haskell value could have +mkDataConWrapperOcc = mk_simple_deriv varName "$W" +mkWorkerOcc = mk_simple_deriv varName "$w" +mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies +mkClassTyConOcc = mk_simple_deriv tcName ":T" -- as a tycon/datacon +mkClassDataConOcc = mk_simple_deriv dataName ":D" -- We go straight to the "real" data con + -- for datacons from classes +mkDictOcc = mk_simple_deriv varName "$d" +mkIPOcc = mk_simple_deriv varName "$i" +mkSpecOcc = mk_simple_deriv varName "$s" +mkForeignExportOcc = mk_simple_deriv varName "$f" + +-- Generic derivable classes +mkGenOcc1 = mk_simple_deriv varName "$gfrom" +mkGenOcc2 = mk_simple_deriv varName "$gto" + +-- data T = MkT ... deriving( Data ) needs defintions for +-- $tT :: Data.Generics.Basics.DataType +-- $cMkT :: Data.Generics.Basics.Constr +mkDataTOcc = mk_simple_deriv varName "$t" +mkDataCOcc = mk_simple_deriv varName "$c" + +mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) + +-- Data constructor workers are made by setting the name space +-- of the data constructor OccName (which should be a DataName) +-- to VarName +mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ +\end{code} + +\begin{code} +mkSuperDictSelOcc :: Int -- Index of superclass, eg 3 + -> OccName -- Class, eg "Ord" + -> OccName -- eg "$p3Ord" +mkSuperDictSelOcc index cls_occ + = mk_deriv varName "$p" (show index ++ occNameString cls_occ) + +mkLocalOcc :: Unique -- Unique + -> OccName -- Local name (e.g. "sat") + -> OccName -- Nice unique version ("$L23sat") +mkLocalOcc uniq occ + = mk_deriv varName ("$L" ++ show uniq) (occNameString occ) + -- The Unique might print with characters + -- that need encoding (e.g. 'z'!) +\end{code} + + +\begin{code} +mkDFunOcc :: String -- Typically the class and type glommed together e.g. "OrdMaybe" + -- Only used in debug mode, for extra clarity + -> Bool -- True <=> hs-boot instance dfun + -> Int -- Unique index + -> OccName -- "$f3OrdMaybe" + +-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real +-- thing when we compile the mother module. Reason: we don't know exactly +-- what the mother module will call it. + +mkDFunOcc info_str is_boot index + = mk_deriv VarName prefix string + where + prefix | is_boot = "$fx" + | otherwise = "$f" + string | opt_PprStyle_Debug = show index ++ info_str + | otherwise = show index +\end{code} + +We used to add a '$m' to indicate a method, but that gives rise to bad +error messages from the type checker when we print the function name or pattern +of an instance-decl binding. Why? Because the binding is zapped +to use the method name in place of the selector name. +(See TcClassDcl.tcMethodBind) + +The way it is now, -ddump-xx output may look confusing, but +you can always say -dppr-debug to get the uniques. + +However, we *do* have to zap the first character to be lower case, +because overloaded constructors (blarg) generate methods too. +And convert to VarName space + +e.g. a call to constructor MkFoo where + data (Ord a) => Foo a = MkFoo a + +If this is necessary, we do it by prefixing '$m'. These +guys never show up in error messages. What a hack. + +\begin{code} +mkMethodOcc :: OccName -> OccName +mkMethodOcc occ@(OccName VarName fs) = occ +mkMethodOcc occ = mk_simple_deriv varName "$m" occ +\end{code} + + +%************************************************************************ +%* * +\subsection{Tidying them up} +%* * +%************************************************************************ + +Before we print chunks of code we like to rename it so that +we don't have to print lots of silly uniques in it. But we mustn't +accidentally introduce name clashes! So the idea is that we leave the +OccName alone unless it accidentally clashes with one that is already +in scope; if so, we tack on '1' at the end and try again, then '2', and +so on till we find a unique one. + +There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' +because that isn't a single lexeme. So we encode it to 'lle' and *then* +tack on the '1', if necessary. + +\begin{code} +type TidyOccEnv = OccEnv Int -- The in-scope OccNames + -- Range gives a plausible starting point for new guesses + +emptyTidyOccEnv = emptyOccEnv + +initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! +initTidyOccEnv = foldl (\env occ -> extendOccEnv env occ 1) emptyTidyOccEnv + +tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) + +tidyOccName in_scope occ@(OccName occ_sp fs) + = case lookupOccEnv in_scope occ of + Nothing -> -- Not already used: make it used + (extendOccEnv in_scope occ 1, occ) + + Just n -> -- Already used: make a new guess, + -- change the guess base, and try again + tidyOccName (extendOccEnv in_scope occ (n+1)) + (mkOccName occ_sp (unpackFS fs ++ show n)) +\end{code} + +%************************************************************************ +%* * + Stuff for dealing with tuples +%* * +%************************************************************************ + +\begin{code} +mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName +mkTupleOcc ns bx ar = OccName ns (mkFastString str) + where + -- no need to cache these, the caching is done in the caller + -- (TysWiredIn.mk_tuple) + str = case bx of + Boxed -> '(' : commas ++ ")" + Unboxed -> '(' : '#' : commas ++ "#)" + + commas = take (ar-1) (repeat ',') + +isTupleOcc_maybe :: OccName -> Maybe (NameSpace, Boxity, Arity) +-- Tuples are special, because there are so many of them! +isTupleOcc_maybe (OccName ns fs) + = case unpackFS fs of + '(':'#':',':rest -> Just (ns, Unboxed, 2 + count_commas rest) + '(':',':rest -> Just (ns, Boxed, 2 + count_commas rest) + _other -> Nothing + where + count_commas (',':rest) = 1 + count_commas rest + count_commas _ = 0 +\end{code} + +%************************************************************************ +%* * +\subsection{Lexical categories} +%* * +%************************************************************************ + +These functions test strings to see if they fit the lexical categories +defined in the Haskell report. + +\begin{code} +isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool +isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool + +isLexCon cs = isLexConId cs || isLexConSym cs +isLexVar cs = isLexVarId cs || isLexVarSym cs + +isLexId cs = isLexConId cs || isLexVarId cs +isLexSym cs = isLexConSym cs || isLexVarSym cs + +------------- + +isLexConId cs -- Prefix type or data constructors + | nullFS cs = False -- e.g. "Foo", "[]", "(,)" + | cs == FSLIT("[]") = True + | otherwise = startsConId (headFS cs) + +isLexVarId cs -- Ordinary prefix identifiers + | nullFS cs = False -- e.g. "x", "_x" + | otherwise = startsVarId (headFS cs) + +isLexConSym cs -- Infix type or data constructors + | nullFS cs = False -- e.g. ":-:", ":", "->" + | cs == FSLIT("->") = True + | otherwise = startsConSym (headFS cs) + +isLexVarSym cs -- Infix identifiers + | nullFS cs = False -- e.g. "+" + | otherwise = startsVarSym (headFS cs) + +------------- +startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool +startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids +startsConSym c = c == ':' -- Infix data constructors +startsVarId c = isLower c || c == '_' -- Ordinary Ids +startsConId c = isUpper c || c == '(' -- Ordinary type constructors and data constructors + +isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" +\end{code} + +%************************************************************************ +%* * + Binary instance + Here rather than BinIface because OccName is abstract +%* * +%************************************************************************ + +\begin{code} +instance Binary NameSpace where + put_ bh VarName = do + putByte bh 0 + put_ bh DataName = do + putByte bh 1 + put_ bh TvName = do + putByte bh 2 + put_ bh TcClsName = do + putByte bh 3 + get bh = do + h <- getByte bh + case h of + 0 -> do return VarName + 1 -> do return DataName + 2 -> do return TvName + _ -> do return TcClsName + +instance Binary OccName where + put_ bh (OccName aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (OccName aa ab) +\end{code} diff --git a/compiler/basicTypes/OccName.lhs-boot b/compiler/basicTypes/OccName.lhs-boot new file mode 100644 index 0000000000..d9c7fcd141 --- /dev/null +++ b/compiler/basicTypes/OccName.lhs-boot @@ -0,0 +1,5 @@ +\begin{code} +module OccName where + +data OccName +\end{code} diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs new file mode 100644 index 0000000000..030aa1f609 --- /dev/null +++ b/compiler/basicTypes/RdrName.lhs @@ -0,0 +1,540 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +\section[RdrName]{@RdrName@} + +\begin{code} +module RdrName ( + RdrName(..), -- Constructors exported only to BinIface + + -- Construction + mkRdrUnqual, mkRdrQual, + mkUnqual, mkVarUnqual, mkQual, mkOrig, + nameRdrName, getRdrName, + mkDerivedRdrName, + + -- Destruction + rdrNameModule, rdrNameOcc, setRdrNameSpace, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, + + -- Printing; instance Outputable RdrName + + -- LocalRdrEnv + LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, + lookupLocalRdrEnv, elemLocalRdrEnv, + + -- GlobalRdrEnv + GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + lookupGlobalRdrEnv, extendGlobalRdrEnv, + pprGlobalRdrEnv, globalRdrEnvElts, + lookupGRE_RdrName, lookupGRE_Name, + + -- GlobalRdrElt, Provenance, ImportSpec + GlobalRdrElt(..), isLocalGRE, unQualOK, + Provenance(..), pprNameProvenance, + ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + importSpecLoc, importSpecModule + ) where + +#include "HsVersions.h" + +import OccName +import Module ( Module, mkModuleFS ) +import Name ( Name, NamedThing(getName), nameModule, nameParent_maybe, + nameOccName, isExternalName, nameSrcLoc ) +import Maybes ( mapCatMaybes ) +import SrcLoc ( isGoodSrcLoc, SrcSpan ) +import FastString ( FastString ) +import Outputable +import Util ( thenCmp ) +\end{code} + +%************************************************************************ +%* * +\subsection{The main data type} +%* * +%************************************************************************ + +\begin{code} +data RdrName + = Unqual OccName + -- Used for ordinary, unqualified occurrences + + | Qual Module OccName + -- A qualified name written by the user in + -- *source* code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported + + | Orig Module OccName + -- An original name; the module is the *defining* module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say "Use Prelude.map dammit". + + | Exact Name + -- We know exactly the Name. This is used + -- (a) when the parser parses built-in syntax like "[]" + -- and "(,)", but wants a RdrName from it + -- (b) when converting names to the RdrNames in IfaceTypes + -- Here an Exact RdrName always contains an External Name + -- (Internal Names are converted to simple Unquals) + -- (c) by Template Haskell, when TH has generated a unique name +\end{code} + + +%************************************************************************ +%* * +\subsection{Simple functions} +%* * +%************************************************************************ + +\begin{code} +rdrNameModule :: RdrName -> Module +rdrNameModule (Qual m _) = m +rdrNameModule (Orig m _) = m +rdrNameModule (Exact n) = nameModule n +rdrNameModule (Unqual n) = pprPanic "rdrNameModule" (ppr n) + +rdrNameOcc :: RdrName -> OccName +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + +setRdrNameSpace :: RdrName -> NameSpace -> RdrName +-- This rather gruesome function is used mainly by the parser +-- When parsing data T a = T | T1 Int +-- we parse the data constructors as *types* because of parser ambiguities, +-- so then we need to change the *type constr* to a *data constr* +-- +-- The original-name case *can* occur when parsing +-- data [] a = [] | a : [a] +-- For the orig-name case we return an unqualified name. +setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) +setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) +setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) +setRdrNameSpace (Exact n) ns = Orig (nameModule n) + (setOccNameSpace ns (nameOccName n)) +\end{code} + +\begin{code} + -- These two are the basic constructors +mkRdrUnqual :: OccName -> RdrName +mkRdrUnqual occ = Unqual occ + +mkRdrQual :: Module -> OccName -> RdrName +mkRdrQual mod occ = Qual mod occ + +mkOrig :: Module -> OccName -> RdrName +mkOrig mod occ = Orig mod occ + +--------------- +mkDerivedRdrName :: Name -> (OccName -> OccName) -> (RdrName) +mkDerivedRdrName parent mk_occ + = mkOrig (nameModule parent) (mk_occ (nameOccName parent)) + +--------------- + -- These two are used when parsing source files + -- They do encode the module and occurrence names +mkUnqual :: NameSpace -> FastString -> RdrName +mkUnqual sp n = Unqual (mkOccNameFS sp n) + +mkVarUnqual :: FastString -> RdrName +mkVarUnqual n = Unqual (mkVarOccFS n) + +mkQual :: NameSpace -> (FastString, FastString) -> RdrName +mkQual sp (m, n) = Qual (mkModuleFS m) (mkOccNameFS sp n) + +getRdrName :: NamedThing thing => thing -> RdrName +getRdrName name = nameRdrName (getName name) + +nameRdrName :: Name -> RdrName +nameRdrName name = Exact name +-- Keep the Name even for Internal names, so that the +-- unique is still there for debug printing, particularly +-- of Types (which are converted to IfaceTypes before printing) + +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModule n) (nameOccName n) + | otherwise = Unqual (nameOccName n) +\end{code} + +\begin{code} +isRdrDataCon rn = isDataOcc (rdrNameOcc rn) +isRdrTyVar rn = isTvOcc (rdrNameOcc rn) +isRdrTc rn = isTcOcc (rdrNameOcc rn) + +isSrcRdrName (Unqual _) = True +isSrcRdrName (Qual _ _) = True +isSrcRdrName _ = False + +isUnqual (Unqual _) = True +isUnqual other = False + +isQual (Qual _ _) = True +isQual _ = False + +isOrig (Orig _ _) = True +isOrig _ = False + +isOrig_maybe (Orig m n) = Just (m,n) +isOrig_maybe _ = Nothing + +isExact (Exact _) = True +isExact other = False + +isExact_maybe (Exact n) = Just n +isExact_maybe other = Nothing +\end{code} + + +%************************************************************************ +%* * +\subsection{Instances} +%* * +%************************************************************************ + +\begin{code} +instance Outputable RdrName where + ppr (Exact name) = ppr name + ppr (Unqual occ) = ppr occ <+> ppr_name_space occ + ppr (Qual mod occ) = ppr mod <> dot <> ppr occ <+> ppr_name_space occ + ppr (Orig mod occ) = ppr mod <> dot <> ppr occ <+> ppr_name_space occ + +ppr_name_space occ = ifPprDebug (parens (pprNonVarNameSpace (occNameSpace occ))) + +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n + | otherwise = ppr n + +instance Eq RdrName where + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + r1 == r2 = False + +instance Ord RdrName where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + + -- Exact < Unqual < Qual < Orig + -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig + -- before comparing so that Prelude.map == the exact Prelude.map, but + -- that meant that we reported duplicates when renaming bindings + -- generated by Template Haskell; e.g + -- do { n1 <- newName "foo"; n2 <- newName "foo"; + -- <decl involving n1,n2> } + -- I think we can do without this conversion + compare (Exact n1) (Exact n2) = n1 `compare` n2 + compare (Exact n1) n2 = LT + + compare (Unqual _) (Exact _) = GT + compare (Unqual o1) (Unqual o2) = o1 `compare` o2 + compare (Unqual _) _ = LT + + compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (Unqual _) = GT + compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Qual _ _) (Orig _ _) = LT + + compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig _ _) _ = GT +\end{code} + + + +%************************************************************************ +%* * + LocalRdrEnv +%* * +%************************************************************************ + +A LocalRdrEnv is used for local bindings (let, where, lambda, case) +It is keyed by OccName, because we never use it for qualified names. + +\begin{code} +type LocalRdrEnv = OccEnv Name + +emptyLocalRdrEnv = emptyOccEnv + +extendLocalRdrEnv :: LocalRdrEnv -> [Name] -> LocalRdrEnv +extendLocalRdrEnv env names + = extendOccEnvList env [(nameOccName n, n) | n <- names] + +lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name +lookupLocalRdrEnv env (Exact name) = Just name +lookupLocalRdrEnv env (Unqual occ) = lookupOccEnv env occ +lookupLocalRdrEnv env other = Nothing + +elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool +elemLocalRdrEnv rdr_name env + | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env + | otherwise = False +\end{code} + + +%************************************************************************ +%* * + GlobalRdrEnv +%* * +%************************************************************************ + +\begin{code} +type GlobalRdrEnv = OccEnv [GlobalRdrElt] + -- Keyed by OccName; when looking up a qualified name + -- we look up the OccName part, and then check the Provenance + -- to see if the appropriate qualification is valid. This + -- saves routinely doubling the size of the env by adding both + -- qualified and unqualified names to the domain. + -- + -- The list in the range is reqd because there may be name clashes + -- These only get reported on lookup, not on construction + + -- INVARIANT: All the members of the list have distinct + -- gre_name fields; that is, no duplicate Names + +emptyGlobalRdrEnv = emptyOccEnv + +globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] +globalRdrEnvElts env = foldOccEnv (++) [] env + +data GlobalRdrElt + = GRE { gre_name :: Name, + gre_prov :: Provenance -- Why it's in scope + } + +instance Outputable GlobalRdrElt where + ppr gre = ppr name <+> pp_parent (nameParent_maybe name) + <+> parens (pprNameProvenance gre) + where + name = gre_name gre + pp_parent (Just p) = brackets (text "parent:" <+> ppr p) + pp_parent Nothing = empty + +pprGlobalRdrEnv :: GlobalRdrEnv -> SDoc +pprGlobalRdrEnv env + = vcat (map pp (occEnvElts env)) + where + pp gres = ppr (nameOccName (gre_name (head gres))) <> colon <+> + vcat [ ppr (gre_name gre) <+> pprNameProvenance gre + | gre <- gres] +\end{code} + +\begin{code} +lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] +lookupGlobalRdrEnv env rdr_name = case lookupOccEnv env rdr_name of + Nothing -> [] + Just gres -> gres + +extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv +extendGlobalRdrEnv env gre = extendOccEnv_C add env occ [gre] + where + occ = nameOccName (gre_name gre) + add gres _ = gre:gres + +lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] +lookupGRE_RdrName rdr_name env + = case lookupOccEnv env (rdrNameOcc rdr_name) of + Nothing -> [] + Just gres -> pickGREs rdr_name gres + +lookupGRE_Name :: GlobalRdrEnv -> Name -> [GlobalRdrElt] +lookupGRE_Name env name + = [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name), + gre_name gre == name ] + + +pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] +-- Take a list of GREs which have the right OccName +-- Pick those GREs that are suitable for this RdrName +-- And for those, keep only only the Provenances that are suitable +-- +-- Consider +-- module A ( f ) where +-- import qualified Foo( f ) +-- import Baz( f ) +-- f = undefined +-- Let's suppose that Foo.f and Baz.f are the same entity really. +-- The export of f is ambiguous because it's in scope from the local def +-- and the import. The lookup of (Unqual f) should return a GRE for +-- the locally-defined f, and a GRE for the imported f, with a *single* +-- provenance, namely the one for Baz(f). +pickGREs rdr_name gres + = mapCatMaybes pick gres + where + is_unqual = isUnqual rdr_name + mod = rdrNameModule rdr_name + + pick :: GlobalRdrElt -> Maybe GlobalRdrElt + pick gre@(GRE {gre_prov = LocalDef, gre_name = n}) -- Local def + | is_unqual || nameModule n == mod = Just gre + | otherwise = Nothing + pick gre@(GRE {gre_prov = Imported [is]}) -- Single import (efficiency) + | is_unqual = if not (is_qual (is_decl is)) then Just gre + else Nothing + | otherwise = if mod == is_as (is_decl is) then Just gre + else Nothing + pick gre@(GRE {gre_prov = Imported is}) -- Multiple import + | null filtered_is = Nothing + | otherwise = Just (gre {gre_prov = Imported filtered_is}) + where + filtered_is | is_unqual = filter (not . is_qual . is_decl) is + | otherwise = filter ((== mod) . is_as . is_decl) is + +isLocalGRE :: GlobalRdrElt -> Bool +isLocalGRE (GRE {gre_prov = LocalDef}) = True +isLocalGRE other = False + +unQualOK :: GlobalRdrElt -> Bool +-- An unqualifed version of this thing is in scope +unQualOK (GRE {gre_prov = LocalDef}) = True +unQualOK (GRE {gre_prov = Imported is}) = not (all (is_qual . is_decl) is) + +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 + +mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv +mkGlobalRdrEnv gres + = foldr add emptyGlobalRdrEnv gres + where + add gre env = extendOccEnv_C (foldr insertGRE) env + (nameOccName (gre_name gre)) + [gre] + +insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] +insertGRE new_g [] = [new_g] +insertGRE new_g (old_g : old_gs) + | gre_name new_g == gre_name old_g + = new_g `plusGRE` old_g : old_gs + | otherwise + = old_g : insertGRE new_g old_gs + +plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt +-- Used when the gre_name fields match +plusGRE g1 g2 + = GRE { gre_name = gre_name g1, + gre_prov = gre_prov g1 `plusProv` gre_prov g2 } +\end{code} + + +%************************************************************************ +%* * + Provenance +%* * +%************************************************************************ + +The "provenance" of something says how it came to be in scope. +It's quite elaborate so that we can give accurate unused-name warnings. + +\begin{code} +data Provenance + = LocalDef -- Defined locally + | Imported -- Imported + [ImportSpec] -- INVARIANT: non-empty + +data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, + is_item :: ImpItemSpec } + deriving( Eq, Ord ) + +data ImpDeclSpec -- Describes a particular import declaration + -- Shared among all the Provenaces for that decl + = ImpDeclSpec { + is_mod :: Module, -- 'import Muggle' + -- Note the Muggle may well not be + -- the defining module for this thing! + is_as :: Module, -- 'as M' (or 'Muggle' if there is no 'as' clause) + is_qual :: Bool, -- True <=> qualified (only) + is_dloc :: SrcSpan -- Location of import declaration + } + +data ImpItemSpec -- Describes import info a particular Name + = ImpAll -- The import had no import list, + -- or had a hiding list + + | ImpSome { -- The import had an import list + is_explicit :: Bool, + is_iloc :: SrcSpan -- Location of the import item + } + -- The is_explicit field is True iff the thing was named + -- *explicitly* in the import specs rather + -- than being imported as part of a "..." group + -- e.g. import C( T(..) ) + -- Here the constructors of T are not named explicitly; + -- only T is named explicitly. + +importSpecLoc :: ImportSpec -> SrcSpan +importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl +importSpecLoc (ImpSpec _ item) = is_iloc item + +importSpecModule :: ImportSpec -> Module +importSpecModule is = is_mod (is_decl is) + +-- Note [Comparing provenance] +-- Comparison of provenance is just used for grouping +-- error messages (in RnEnv.warnUnusedBinds) +instance Eq Provenance where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Eq ImpDeclSpec where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Eq ImpItemSpec where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Ord Provenance where + compare LocalDef LocalDef = EQ + compare LocalDef (Imported _) = LT + compare (Imported _ ) LocalDef = GT + compare (Imported is1) (Imported is2) = compare (head is1) + {- See Note [Comparing provenance] -} (head is2) + +instance Ord ImpDeclSpec where + compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp` + (is_dloc is1 `compare` is_dloc is2) + +instance Ord ImpItemSpec where + compare is1 is2 = is_iloc is1 `compare` is_iloc is2 +\end{code} + +\begin{code} +plusProv :: Provenance -> Provenance -> Provenance +-- Choose LocalDef over Imported +-- There is an obscure bug lurking here; in the presence +-- of recursive modules, something can be imported *and* locally +-- defined, and one might refer to it with a qualified name from +-- the import -- but I'm going to ignore that because it makes +-- the isLocalGRE predicate so much nicer this way +plusProv LocalDef LocalDef = panic "plusProv" +plusProv LocalDef p2 = LocalDef +plusProv p1 LocalDef = LocalDef +plusProv (Imported is1) (Imported is2) = Imported (is1++is2) + +pprNameProvenance :: GlobalRdrElt -> SDoc +-- Print out the place where the name was imported +pprNameProvenance (GRE {gre_name = name, gre_prov = LocalDef}) + = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) +pprNameProvenance (GRE {gre_name = name, gre_prov = Imported (why:whys)}) + = sep [ppr why, nest 2 (ppr_defn (nameSrcLoc name))] + +-- If we know the exact definition point (which we may do with GHCi) +-- then show that too. But not if it's just "imported from X". +ppr_defn loc | isGoodSrcLoc loc = parens (ptext SLIT("defined at") <+> ppr loc) + | otherwise = empty + +instance Outputable ImportSpec where + ppr imp_spec@(ImpSpec imp_decl _) + = ptext SLIT("imported from") <+> ppr (is_mod imp_decl) + <+> ptext SLIT("at") <+> ppr (importSpecLoc imp_spec) +\end{code} diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs new file mode 100644 index 0000000000..51d4318b0b --- /dev/null +++ b/compiler/basicTypes/SrcLoc.lhs @@ -0,0 +1,386 @@ +% +% (c) The University of Glasgow, 1992-2003 +% +%************************************************************************ +%* * +\section[SrcLoc]{The @SrcLoc@ type} +%* * +%************************************************************************ + +\begin{code} +module SrcLoc ( + SrcLoc, -- Abstract + + mkSrcLoc, isGoodSrcLoc, mkGeneralSrcLoc, + noSrcLoc, -- "I'm sorry, I haven't a clue" + advanceSrcLoc, + + importedSrcLoc, -- Unknown place in an interface + wiredInSrcLoc, -- Something wired into the compiler + generatedSrcLoc, -- Code generated within the compiler + interactiveSrcLoc, -- Code from an interactive session + + srcLocFile, -- return the file name part + srcLocLine, -- return the line part + srcLocCol, -- return the column part + pprDefnLoc, + + SrcSpan, -- Abstract + noSrcSpan, + mkGeneralSrcSpan, + isGoodSrcSpan, + mkSrcSpan, srcLocSpan, + combineSrcSpans, + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + srcSpanStart, srcSpanEnd, + + Located(..), getLoc, unLoc, noLoc, eqLocated, cmpLocated, combineLocs, addCLoc + ) where + +#include "HsVersions.h" + +import Util ( thenCmp ) +import Outputable +import FastString +\end{code} + +%************************************************************************ +%* * +\subsection[SrcLoc-SrcLocations]{Source-location information} +%* * +%************************************************************************ + +We keep information about the {\em definition} point for each entity; +this is the obvious stuff: +\begin{code} +data SrcLoc + = SrcLoc FastString -- A precise location (file name) + !Int -- line number, begins at 1 + !Int -- column number, begins at 0 + -- Don't ask me why lines start at 1 and columns start at + -- zero. That's just the way it is, so there. --SDM + + | ImportedLoc String -- Module name + + | UnhelpfulLoc FastString -- Just a general indication +\end{code} + +Note that an entity might be imported via more than one route, and +there could be more than one ``definition point'' --- in two or more +\tr{.hi} files. We deemed it probably-unworthwhile to cater for this +rare case. + +%************************************************************************ +%* * +\subsection[SrcLoc-access-fns]{Access functions for names} +%* * +%************************************************************************ + +Things to make 'em: +\begin{code} +mkSrcLoc x line col = SrcLoc x line col +noSrcLoc = UnhelpfulLoc FSLIT("<no location info>") +generatedSrcLoc = UnhelpfulLoc FSLIT("<compiler-generated code>") +wiredInSrcLoc = UnhelpfulLoc FSLIT("<wired into compiler>") +interactiveSrcLoc = UnhelpfulLoc FSLIT("<interactive session>") + +mkGeneralSrcLoc :: FastString -> SrcLoc +mkGeneralSrcLoc = UnhelpfulLoc + +importedSrcLoc :: String -> SrcLoc +importedSrcLoc mod_name = ImportedLoc mod_name + +isGoodSrcLoc (SrcLoc _ _ _) = True +isGoodSrcLoc other = False + +srcLocFile :: SrcLoc -> FastString +srcLocFile (SrcLoc fname _ _) = fname +srcLocFile other = FSLIT("<unknown file") + +srcLocLine :: SrcLoc -> Int +srcLocLine (SrcLoc _ l c) = l +srcLocLine other = panic "srcLocLine: unknown line" + +srcLocCol :: SrcLoc -> Int +srcLocCol (SrcLoc _ l c) = c +srcLocCol other = panic "srcLocCol: unknown col" + +advanceSrcLoc :: SrcLoc -> Char -> SrcLoc +advanceSrcLoc (SrcLoc f l c) '\n' = SrcLoc f (l + 1) 0 +advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) +advanceSrcLoc loc _ = loc -- Better than nothing +\end{code} + +%************************************************************************ +%* * +\subsection[SrcLoc-instances]{Instance declarations for various names} +%* * +%************************************************************************ + +\begin{code} +-- SrcLoc is an instance of Ord so that we can sort error messages easily +instance Eq SrcLoc where + loc1 == loc2 = case loc1 `cmpSrcLoc` loc2 of + EQ -> True + other -> False + +instance Ord SrcLoc where + compare = cmpSrcLoc + +cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2 +cmpSrcLoc (UnhelpfulLoc _) other = LT + +cmpSrcLoc (ImportedLoc _) (UnhelpfulLoc _) = GT +cmpSrcLoc (ImportedLoc m1) (ImportedLoc m2) = m1 `compare` m2 +cmpSrcLoc (ImportedLoc _) other = LT + +cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2) + = (s1 `compare` s2) `thenCmp` (l1 `cmpline` l2) `thenCmp` (c1 `cmpline` c2) + where + l1 `cmpline` l2 | l1 < l2 = LT + | l1 == l2 = EQ + | otherwise = GT +cmpSrcLoc (SrcLoc _ _ _) other = GT + +instance Outputable SrcLoc where + ppr (SrcLoc src_path src_line src_col) + = getPprStyle $ \ sty -> + if userStyle sty || debugStyle sty then + hcat [ ftext src_path, char ':', + int src_line, + char ':', int src_col + ] + else + hcat [text "{-# LINE ", int src_line, space, + char '\"', ftext src_path, text " #-}"] + + ppr (ImportedLoc mod) = ptext SLIT("Imported from") <+> text mod + ppr (UnhelpfulLoc s) = ftext s +\end{code} + +%************************************************************************ +%* * +\subsection[SrcSpan]{Source Spans} +%* * +%************************************************************************ + +\begin{code} +{- | +A SrcSpan delimits a portion of a text file. It could be represented +by a pair of (line,column) coordinates, but in fact we optimise +slightly by using more compact representations for single-line and +zero-length spans, both of which are quite common. + +The end position is defined to be the column *after* the end of the +span. That is, a span of (1,1)-(1,2) is one character long, and a +span of (1,1)-(1,1) is zero characters long. +-} +data SrcSpan + = SrcSpanOneLine -- a common case: a single line + { srcSpanFile :: FastString, + srcSpanLine :: !Int, + srcSpanSCol :: !Int, + srcSpanECol :: !Int + } + + | SrcSpanMultiLine + { srcSpanFile :: FastString, + srcSpanSLine :: !Int, + srcSpanSCol :: !Int, + srcSpanELine :: !Int, + srcSpanECol :: !Int + } + + | SrcSpanPoint + { srcSpanFile :: FastString, + srcSpanLine :: !Int, + srcSpanCol :: !Int + } + + | ImportedSpan String -- Module name + + | UnhelpfulSpan FastString -- Just a general indication + -- also used to indicate an empty span + + deriving Eq + +-- We want to order SrcSpans first by the start point, then by the end point. +instance Ord SrcSpan where + a `compare` b = + (srcSpanStart a `compare` srcSpanStart b) `thenCmp` + (srcSpanEnd a `compare` srcSpanEnd b) + +noSrcSpan = UnhelpfulSpan FSLIT("<no location info>") + +mkGeneralSrcSpan :: FastString -> SrcSpan +mkGeneralSrcSpan = UnhelpfulSpan + +isGoodSrcSpan SrcSpanOneLine{} = True +isGoodSrcSpan SrcSpanMultiLine{} = True +isGoodSrcSpan SrcSpanPoint{} = True +isGoodSrcSpan _ = False + +srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l +srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l +srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l +srcSpanStartLine _ = panic "SrcLoc.srcSpanStartLine" + +srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l +srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l +srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l +srcSpanEndLine _ = panic "SrcLoc.srcSpanEndLine" + +srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l +srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l +srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l +srcSpanStartCol _ = panic "SrcLoc.srcSpanStartCol" + +srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c +srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c +srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c +srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol" + +srcSpanStart (ImportedSpan str) = ImportedLoc str +srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanStart s = + mkSrcLoc (srcSpanFile s) + (srcSpanStartLine s) + (srcSpanStartCol s) + +srcSpanEnd (ImportedSpan str) = ImportedLoc str +srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanEnd s = + mkSrcLoc (srcSpanFile s) + (srcSpanEndLine s) + (srcSpanEndCol s) + +srcLocSpan :: SrcLoc -> SrcSpan +srcLocSpan (ImportedLoc str) = ImportedSpan str +srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str +srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col + +mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan +mkSrcSpan (ImportedLoc str) _ = ImportedSpan str +mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str +mkSrcSpan _ (ImportedLoc str) = ImportedSpan str +mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str +mkSrcSpan loc1 loc2 + | line1 == line2 = if col1 == col2 + then SrcSpanPoint file line1 col1 + else SrcSpanOneLine file line1 col1 col2 + | otherwise = SrcSpanMultiLine file line1 col1 line2 col2 + where + line1 = srcLocLine loc1 + line2 = srcLocLine loc2 + col1 = srcLocCol loc1 + col2 = srcLocCol loc2 + file = srcLocFile loc1 + +combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan +-- Assumes the 'file' part is the same in both +combineSrcSpans (ImportedSpan str) _ = ImportedSpan str +combineSrcSpans (UnhelpfulSpan str) r = r -- this seems more useful +combineSrcSpans _ (ImportedSpan str) = ImportedSpan str +combineSrcSpans l (UnhelpfulSpan str) = l +combineSrcSpans start end + = case line1 `compare` line2 of + EQ -> case col1 `compare` col2 of + EQ -> SrcSpanPoint file line1 col1 + LT -> SrcSpanOneLine file line1 col1 col2 + GT -> SrcSpanOneLine file line1 col2 col1 + LT -> SrcSpanMultiLine file line1 col1 line2 col2 + GT -> SrcSpanMultiLine file line2 col2 line1 col1 + where + line1 = srcSpanStartLine start + col1 = srcSpanStartCol start + line2 = srcSpanEndLine end + col2 = srcSpanEndCol end + file = srcSpanFile start + +pprDefnLoc :: SrcLoc -> SDoc +-- "defined at ..." or "imported from ..." +pprDefnLoc loc + | isGoodSrcLoc loc = ptext SLIT("Defined at") <+> ppr loc + | otherwise = ppr loc + +instance Outputable SrcSpan where + ppr span + = getPprStyle $ \ sty -> + if userStyle sty || debugStyle sty then + pprUserSpan span + else + hcat [text "{-# LINE ", int (srcSpanStartLine span), space, + char '\"', ftext (srcSpanFile span), text " #-}"] + + +pprUserSpan (SrcSpanOneLine src_path line start_col end_col) + = hcat [ ftext src_path, char ':', + int line, + char ':', int start_col + ] + <> if end_col - start_col <= 1 + then empty + -- for single-character or point spans, we just output the starting + -- column number + else char '-' <> int (end_col-1) + +pprUserSpan (SrcSpanMultiLine src_path sline scol eline ecol) + = hcat [ ftext src_path, char ':', + parens (int sline <> char ',' <> int scol), + char '-', + parens (int eline <> char ',' <> + if ecol == 0 then int ecol else int (ecol-1)) + ] + +pprUserSpan (SrcSpanPoint src_path line col) + = hcat [ ftext src_path, char ':', + int line, + char ':', int col + ] + +pprUserSpan (ImportedSpan mod) = ptext SLIT("Imported from") <+> quotes (text mod) +pprUserSpan (UnhelpfulSpan s) = ftext s +\end{code} + +%************************************************************************ +%* * +\subsection[Located]{Attaching SrcSpans to things} +%* * +%************************************************************************ + +\begin{code} +-- | We attach SrcSpans to lots of things, so let's have a datatype for it. +data Located e = L SrcSpan e + +unLoc :: Located e -> e +unLoc (L _ e) = e + +getLoc :: Located e -> SrcSpan +getLoc (L l _) = l + +noLoc :: e -> Located e +noLoc e = L noSrcSpan e + +combineLocs :: Located a -> Located b -> SrcSpan +combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) + +addCLoc :: Located a -> Located b -> c -> Located c +addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c + +-- not clear whether to add a general Eq instance, but this is useful sometimes: +eqLocated :: Eq a => Located a -> Located a -> Bool +eqLocated a b = unLoc a == unLoc b + +-- not clear whether to add a general Eq instance, but this is useful sometimes: +cmpLocated :: Ord a => Located a -> Located a -> Ordering +cmpLocated a b = unLoc a `compare` unLoc b + +instance Functor Located where + fmap f (L l e) = L l (f e) + +instance Outputable e => Outputable (Located e) where + ppr (L span e) = ppr e + -- do we want to dump the span in debugSty mode? +\end{code} diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs new file mode 100644 index 0000000000..41ad5c0f60 --- /dev/null +++ b/compiler/basicTypes/UniqSupply.lhs @@ -0,0 +1,203 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[UniqSupply]{The @UniqueSupply@ data type and a (monadic) supply thereof} + +\begin{code} +module UniqSupply ( + + UniqSupply, -- Abstractly + + uniqFromSupply, uniqsFromSupply, -- basic ops + + UniqSM, -- type: unique supply monad + initUs, initUs_, thenUs, thenUs_, returnUs, fixUs, getUs, withUs, + getUniqueUs, getUniquesUs, + mapUs, mapAndUnzipUs, mapAndUnzip3Us, + thenMaybeUs, mapAccumLUs, + lazyThenUs, lazyMapUs, + + mkSplitUniqSupply, + splitUniqSupply + ) where + +#include "HsVersions.h" + +import Unique + +import GLAEXTS +import UNSAFE_IO ( unsafeInterleaveIO ) + +w2i x = word2Int# x +i2w x = int2Word# x +i2w_s x = (x :: Int#) +\end{code} + + +%************************************************************************ +%* * +\subsection{Splittable Unique supply: @UniqSupply@} +%* * +%************************************************************************ + +A value of type @UniqSupply@ is unique, and it can +supply {\em one} distinct @Unique@. Also, from the supply, one can +also manufacture an arbitrary number of further @UniqueSupplies@, +which will be distinct from the first and from all others. + +\begin{code} +data UniqSupply + = MkSplitUniqSupply Int -- make the Unique with this + UniqSupply UniqSupply + -- when split => these two supplies +\end{code} + +\begin{code} +mkSplitUniqSupply :: Char -> IO UniqSupply + +splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) +uniqFromSupply :: UniqSupply -> Unique +uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite +\end{code} + +\begin{code} +mkSplitUniqSupply (C# c#) + = let +#if __GLASGOW_HASKELL__ >= 503 + mask# = (i2w (ord# c#)) `uncheckedShiftL#` (i2w_s 24#) +#else + mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#) +#endif + -- here comes THE MAGIC: + + -- This is one of the most hammered bits in the whole compiler + mk_supply# + = unsafeInterleaveIO ( + mk_unique >>= \ uniq -> + mk_supply# >>= \ s1 -> + mk_supply# >>= \ s2 -> + return (MkSplitUniqSupply uniq s1 s2) + ) + + mk_unique = genSymZh >>= \ (W# u#) -> + return (I# (w2i (mask# `or#` u#))) + in + mk_supply# + +foreign import ccall unsafe "genSymZh" genSymZh :: IO Word + +splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) +\end{code} + +\begin{code} +uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n +uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 +\end{code} + +%************************************************************************ +%* * +\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} +%* * +%************************************************************************ + +\begin{code} +type UniqSM result = UniqSupply -> (result, UniqSupply) + +-- the initUs function also returns the final UniqSupply; initUs_ drops it +initUs :: UniqSupply -> UniqSM a -> (a,UniqSupply) +initUs init_us m = case m init_us of { (r,us) -> (r,us) } + +initUs_ :: UniqSupply -> UniqSM a -> a +initUs_ init_us m = case m init_us of { (r,us) -> r } + +{-# INLINE thenUs #-} +{-# INLINE lazyThenUs #-} +{-# INLINE returnUs #-} +{-# INLINE splitUniqSupply #-} +\end{code} + +@thenUs@ is where we split the @UniqSupply@. +\begin{code} +fixUs :: (a -> UniqSM a) -> UniqSM a +fixUs m us + = (r,us') where (r,us') = m r us + +thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b +thenUs expr cont us + = case (expr us) of { (result, us') -> cont result us' } + +lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b +lazyThenUs expr cont us + = let (result, us') = expr us in cont result us' + +thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b +thenUs_ expr cont us + = case (expr us) of { (_, us') -> cont us' } + + +returnUs :: a -> UniqSM a +returnUs result us = (result, us) + +withUs :: (UniqSupply -> (a, UniqSupply)) -> UniqSM a +withUs f us = f us -- Ha ha! + +getUs :: UniqSM UniqSupply +getUs us = splitUniqSupply us + +getUniqueUs :: UniqSM Unique +getUniqueUs us = case splitUniqSupply us of + (us1,us2) -> (uniqFromSupply us1, us2) + +getUniquesUs :: UniqSM [Unique] +getUniquesUs us = case splitUniqSupply us of + (us1,us2) -> (uniqsFromSupply us1, us2) +\end{code} + +\begin{code} +mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] +mapUs f [] = returnUs [] +mapUs f (x:xs) + = f x `thenUs` \ r -> + mapUs f xs `thenUs` \ rs -> + returnUs (r:rs) + +lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] +lazyMapUs f [] = returnUs [] +lazyMapUs f (x:xs) + = f x `lazyThenUs` \ r -> + lazyMapUs f xs `lazyThenUs` \ rs -> + returnUs (r:rs) + +mapAndUnzipUs :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) +mapAndUnzip3Us :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d]) + +mapAndUnzipUs f [] = returnUs ([],[]) +mapAndUnzipUs f (x:xs) + = f x `thenUs` \ (r1, r2) -> + mapAndUnzipUs f xs `thenUs` \ (rs1, rs2) -> + returnUs (r1:rs1, r2:rs2) + +mapAndUnzip3Us f [] = returnUs ([],[],[]) +mapAndUnzip3Us f (x:xs) + = f x `thenUs` \ (r1, r2, r3) -> + mapAndUnzip3Us f xs `thenUs` \ (rs1, rs2, rs3) -> + returnUs (r1:rs1, r2:rs2, r3:rs3) + +thenMaybeUs :: UniqSM (Maybe a) -> (a -> UniqSM (Maybe b)) -> UniqSM (Maybe b) +thenMaybeUs m k + = m `thenUs` \ result -> + case result of + Nothing -> returnUs Nothing + Just x -> k x + +mapAccumLUs :: (acc -> x -> UniqSM (acc, y)) + -> acc + -> [x] + -> UniqSM (acc, [y]) + +mapAccumLUs f b [] = returnUs (b, []) +mapAccumLUs f b (x:xs) + = f b x `thenUs` \ (b__2, x__2) -> + mapAccumLUs f b__2 xs `thenUs` \ (b__3, xs__2) -> + returnUs (b__3, x__2:xs__2) +\end{code} diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs new file mode 100644 index 0000000000..874328863e --- /dev/null +++ b/compiler/basicTypes/Unique.lhs @@ -0,0 +1,330 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +@Uniques@ are used to distinguish entities in the compiler (@Ids@, +@Classes@, etc.) from each other. Thus, @Uniques@ are the basic +comparison key in the compiler. + +If there is any single operation that needs to be fast, it is @Unique@ +comparison. Unsurprisingly, there is quite a bit of huff-and-puff +directed to that end. + +Some of the other hair in this code is to be able to use a +``splittable @UniqueSupply@'' if requested/possible (not standard +Haskell). + +\begin{code} +module Unique ( + Unique, Uniquable(..), hasKey, + + pprUnique, + + mkUnique, -- Used in UniqSupply + mkUniqueGrimily, -- Used in UniqSupply only! + getKey, getKey#, -- Used in Var, UniqFM, Name only! + + incrUnique, -- Used for renumbering + deriveUnique, -- Ditto + newTagUnique, -- Used in CgCase + initTyVarUnique, + + isTupleKey, + + -- now all the built-in Uniques (and functions to make them) + -- [the Oh-So-Wonderful Haskell module system wins again...] + mkAlphaTyVarUnique, + mkPrimOpIdUnique, + mkTupleTyConUnique, mkTupleDataConUnique, + mkPreludeMiscIdUnique, mkPreludeDataConUnique, + mkPreludeTyConUnique, mkPreludeClassUnique, + mkPArrDataConUnique, + + mkBuiltinUnique, + mkPseudoUniqueC, + mkPseudoUniqueD, + mkPseudoUniqueE, + mkPseudoUniqueH + ) where + +#include "HsVersions.h" + +import BasicTypes ( Boxity(..) ) +import PackageConfig ( PackageId, packageIdFS ) +import FastString ( FastString, uniqueOfFS ) +import Outputable +import FastTypes + +import GLAEXTS + +import Char ( chr, ord ) +\end{code} + +%************************************************************************ +%* * +\subsection[Unique-type]{@Unique@ type and operations} +%* * +%************************************************************************ + +The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. +Fast comparison is everything on @Uniques@: + +\begin{code} +data Unique = MkUnique Int# +\end{code} + +Now come the functions which construct uniques from their pieces, and vice versa. +The stuff about unique *supplies* is handled further down this module. + +\begin{code} +mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces +unpkUnique :: Unique -> (Char, Int) -- The reverse + +mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply +getKey :: Unique -> Int -- for Var +getKey# :: Unique -> Int# -- for Var + +incrUnique :: Unique -> Unique +deriveUnique :: Unique -> Int -> Unique +newTagUnique :: Unique -> Char -> Unique + +isTupleKey :: Unique -> Bool +\end{code} + + +\begin{code} +mkUniqueGrimily (I# x) = MkUnique x + +{-# INLINE getKey #-} +getKey (MkUnique x) = I# x +{-# INLINE getKey# #-} +getKey# (MkUnique x) = x + +incrUnique (MkUnique i) = MkUnique (i +# 1#) + +-- deriveUnique uses an 'X' tag so that it won't clash with +-- any of the uniques produced any other way +deriveUnique (MkUnique i) delta = mkUnique 'X' (I# i + delta) + +-- newTagUnique changes the "domain" of a unique to a different char +newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u + +-- pop the Char in the top 8 bits of the Unique(Supply) + +-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM + +w2i x = word2Int# x +i2w x = int2Word# x +i2w_s x = (x::Int#) + +mkUnique (C# c) (I# i) + = MkUnique (w2i (tag `or#` bits)) + where +#if __GLASGOW_HASKELL__ >= 503 + tag = i2w (ord# c) `uncheckedShiftL#` i2w_s 24# +#else + tag = i2w (ord# c) `shiftL#` i2w_s 24# +#endif + bits = i2w i `and#` (i2w 16777215#){-``0x00ffffff''-} + +unpkUnique (MkUnique u) + = let + tag = C# (chr# (w2i ((i2w u) `shiftr` (i2w_s 24#)))) + i = I# (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-})) + in + (tag, i) + where +#if __GLASGOW_HASKELL__ >= 503 + shiftr x y = uncheckedShiftRL# x y +#else + shiftr x y = shiftRL# x y +#endif +\end{code} + + + +%************************************************************************ +%* * +\subsection[Uniquable-class]{The @Uniquable@ class} +%* * +%************************************************************************ + +\begin{code} +class Uniquable a where + getUnique :: a -> Unique + +hasKey :: Uniquable a => a -> Unique -> Bool +x `hasKey` k = getUnique x == k + +instance Uniquable FastString where + getUnique fs = mkUniqueGrimily (I# (uniqueOfFS fs)) + +instance Uniquable PackageId where + getUnique pid = getUnique (packageIdFS pid) + +instance Uniquable Int where + getUnique i = mkUniqueGrimily i +\end{code} + + +%************************************************************************ +%* * +\subsection[Unique-instances]{Instance declarations for @Unique@} +%* * +%************************************************************************ + +And the whole point (besides uniqueness) is fast equality. We don't +use `deriving' because we want {\em precise} control of ordering +(equality on @Uniques@ is v common). + +\begin{code} +eqUnique (MkUnique u1) (MkUnique u2) = u1 ==# u2 +ltUnique (MkUnique u1) (MkUnique u2) = u1 <# u2 +leUnique (MkUnique u1) (MkUnique u2) = u1 <=# u2 + +cmpUnique (MkUnique u1) (MkUnique u2) + = if u1 ==# u2 then EQ else if u1 <# u2 then LT else GT + +instance Eq Unique where + a == b = eqUnique a b + a /= b = not (eqUnique a b) + +instance Ord Unique where + a < b = ltUnique a b + a <= b = leUnique a b + a > b = not (leUnique a b) + a >= b = not (ltUnique a b) + compare a b = cmpUnique a b + +----------------- +instance Uniquable Unique where + getUnique u = u +\end{code} + +We do sometimes make strings with @Uniques@ in them: +\begin{code} +pprUnique :: Unique -> SDoc +pprUnique uniq + = case unpkUnique uniq of + (tag, u) -> finish_ppr tag u (text (iToBase62 u)) + +#ifdef UNUSED +pprUnique10 :: Unique -> SDoc +pprUnique10 uniq -- in base-10, dudes + = case unpkUnique uniq of + (tag, u) -> finish_ppr tag u (int u) +#endif + +finish_ppr 't' u pp_u | u < 26 + = -- Special case to make v common tyvars, t1, t2, ... + -- come out as a, b, ... (shorter, easier to read) + char (chr (ord 'a' + u)) +finish_ppr tag u pp_u = char tag <> pp_u + +instance Outputable Unique where + ppr u = pprUnique u + +instance Show Unique where + showsPrec p uniq = showsPrecSDoc p (pprUnique uniq) +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-base62]{Base-62 numbers} +%* * +%************************************************************************ + +A character-stingy way to read/write numbers (notably Uniques). +The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. +Code stolen from Lennart. + +\begin{code} +iToBase62 :: Int -> String +iToBase62 n@(I# n#) + = ASSERT(n >= 0) go n# "" + where + go n# cs | n# <# 62# + = case (indexCharOffAddr# chars62# n#) of { c# -> C# c# : cs } + | otherwise + = case (quotRem (I# n#) 62) of { (I# q#, I# r#) -> + case (indexCharOffAddr# chars62# r#) of { c# -> + go q# (C# c# : cs) }} + + chars62# = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# +\end{code} + +%************************************************************************ +%* * +\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} +%* * +%************************************************************************ + +Allocation of unique supply characters: + v,t,u : for renumbering value-, type- and usage- vars. + B: builtin + C-E: pseudo uniques (used in native-code generator) + X: uniques derived by deriveUnique + _: unifiable tyvars (above) + 0-9: prelude things below + + other a-z: lower case chars for unique supplies. Used so far: + + d desugarer + f AbsC flattener + g SimplStg + l ndpFlatten + n Native codegen + r Hsc name cache + s simplifier + +\begin{code} +mkAlphaTyVarUnique i = mkUnique '1' i + +mkPreludeClassUnique i = mkUnique '2' i + +-- Prelude type constructors occupy *three* slots. +-- The first is for the tycon itself; the latter two +-- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info. + +mkPreludeTyConUnique i = mkUnique '3' (3*i) +mkTupleTyConUnique Boxed a = mkUnique '4' (3*a) +mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a) + +-- Data constructor keys occupy *two* slots. The first is used for the +-- data constructor itself and its wrapper function (the function that +-- evaluates arguments as necessary and calls the worker). The second is +-- used for the worker function (the function that builds the constructor +-- representation). + +mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic +mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) +mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a) + +-- This one is used for a tiresome reason +-- to improve a consistency-checking error check in the renamer +isTupleKey u = case unpkUnique u of + (tag,_) -> tag == '4' || tag == '5' || tag == '7' || tag == '8' + +mkPrimOpIdUnique op = mkUnique '9' op +mkPreludeMiscIdUnique i = mkUnique '0' i + +-- No numbers left anymore, so I pick something different for the character +-- tag +mkPArrDataConUnique a = mkUnique ':' (2*a) + +-- The "tyvar uniques" print specially nicely: a, b, c, etc. +-- See pprUnique for details + +initTyVarUnique :: Unique +initTyVarUnique = mkUnique 't' 0 + +mkPseudoUniqueC, mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, + mkBuiltinUnique :: Int -> Unique + +mkBuiltinUnique i = mkUnique 'B' i +mkPseudoUniqueC i = mkUnique 'C' i -- used for getUnique on Regs +mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs +mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs +mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs +\end{code} + diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs new file mode 100644 index 0000000000..60fdf3831c --- /dev/null +++ b/compiler/basicTypes/Var.lhs @@ -0,0 +1,337 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section{@Vars@: Variables} + +\begin{code} +module Var ( + Var, + varName, varUnique, + setVarName, setVarUnique, + + -- TyVars + TyVar, mkTyVar, mkTcTyVar, + tyVarName, tyVarKind, + setTyVarName, setTyVarUnique, + tcTyVarDetails, + + -- Ids + Id, DictId, + idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo, + setIdName, setIdUnique, setIdType, setIdInfo, lazySetIdInfo, + setIdExported, setIdNotExported, + + globalIdDetails, globaliseId, + + mkLocalId, mkExportedLocalId, mkGlobalId, + + isTyVar, isTcTyVar, isId, isLocalVar, isLocalId, + isGlobalId, isExportedId, + mustHaveLocalBinding + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} TypeRep( Type ) +import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails ) +import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, IdInfo, seqIdInfo ) + +import Name ( Name, NamedThing(..), + setNameUnique, nameUnique + ) +import Kind ( Kind ) +import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey# ) +import FastTypes +import Outputable +\end{code} + + +%************************************************************************ +%* * +\subsection{The main data type declarations} +%* * +%************************************************************************ + + +Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a +@Type@, and an @IdInfo@ (non-essential info about it, e.g., +strictness). The essential info about different kinds of @Vars@ is +in its @VarDetails@. + +\begin{code} +data Var + = TyVar { + varName :: !Name, + realUnique :: FastInt, -- Key for fast comparison + -- Identical to the Unique in the name, + -- cached here for speed + tyVarKind :: Kind } + + | TcTyVar { -- Used only during type inference + varName :: !Name, + realUnique :: FastInt, + tyVarKind :: Kind, + tcTyVarDetails :: TcTyVarDetails } + + | GlobalId { -- Used for imported Ids, dict selectors etc + varName :: !Name, + realUnique :: FastInt, + idType :: Type, + idInfo :: IdInfo, + gblDetails :: GlobalIdDetails } + + | LocalId { -- Used for locally-defined Ids (see NOTE below) + varName :: !Name, + realUnique :: FastInt, + idType :: Type, + idInfo :: IdInfo, + lclDetails :: LocalIdDetails } + +data LocalIdDetails + = NotExported -- Not exported + | Exported -- Exported + -- Exported Ids are kept alive; + -- NotExported things may be discarded as dead code. +\end{code} + +LocalId and GlobalId +~~~~~~~~~~~~~~~~~~~~ +A GlobalId is + * always a constant (top-level) + * imported, or data constructor, or primop, or record selector + * has a Unique that is globally unique across the whole + GHC invocation (a single invocation may compile multiple modules) + +A LocalId is + * bound within an expression (lambda, case, local let(rec)) + * or defined at top level in the module being compiled + +After CoreTidy, top-level LocalIds are turned into GlobalIds + + +\begin{code} +instance Outputable Var where + ppr var = ppr (varName var) <+> ifPprDebug (brackets extra) + where + extra = case var of + GlobalId {} -> ptext SLIT("gid") + LocalId {} -> ptext SLIT("lid") + TyVar {} -> ptext SLIT("tv") + TcTyVar {tcTyVarDetails = details} -> pprTcTyVarDetails details + +instance Show Var where + showsPrec p var = showsPrecSDoc p (ppr var) + +instance NamedThing Var where + getName = varName + +instance Uniquable Var where + getUnique = varUnique + +instance Eq Var where + a == b = realUnique a ==# realUnique b + +instance Ord Var where + a <= b = realUnique a <=# realUnique b + a < b = realUnique a <# realUnique b + a >= b = realUnique a >=# realUnique b + a > b = realUnique a ># realUnique b + a `compare` b = varUnique a `compare` varUnique b +\end{code} + + +\begin{code} +varUnique :: Var -> Unique +varUnique var = mkUniqueGrimily (iBox (realUnique var)) + +setVarUnique :: Var -> Unique -> Var +setVarUnique var uniq + = var { realUnique = getKey# uniq, + varName = setNameUnique (varName var) uniq } + +setVarName :: Var -> Name -> Var +setVarName var new_name + = var { realUnique = getKey# (getUnique new_name), + varName = new_name } +\end{code} + + +%************************************************************************ +%* * +\subsection{Type variables} +%* * +%************************************************************************ + +\begin{code} +type TyVar = Var + +tyVarName = varName + +setTyVarUnique = setVarUnique +setTyVarName = setVarName +\end{code} + +\begin{code} +mkTyVar :: Name -> Kind -> TyVar +mkTyVar name kind = TyVar { varName = name + , realUnique = getKey# (nameUnique name) + , tyVarKind = kind + } + +mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar +mkTcTyVar name kind details + = TcTyVar { varName = name, + realUnique = getKey# (nameUnique name), + tyVarKind = kind, + tcTyVarDetails = details + } +\end{code} + + +%************************************************************************ +%* * +\subsection{Id Construction} +%* * +%************************************************************************ + +Most Id-related functions are in Id.lhs and MkId.lhs + +\begin{code} +type Id = Var +type DictId = Id +\end{code} + +\begin{code} +idName = varName +idUnique = varUnique + +setIdUnique :: Id -> Unique -> Id +setIdUnique = setVarUnique + +setIdName :: Id -> Name -> Id +setIdName = setVarName + +setIdType :: Id -> Type -> Id +setIdType id ty = id {idType = ty} + +setIdExported :: Id -> Id +-- Can be called on GlobalIds, such as data cons and class ops, +-- which are "born" as GlobalIds and automatically exported +setIdExported id@(LocalId {}) = id { lclDetails = Exported } +setIdExported other_id = ASSERT( isId other_id ) other_id + +setIdNotExported :: Id -> Id +-- We can only do this to LocalIds +setIdNotExported id = ASSERT( isLocalId id ) id { lclDetails = NotExported } + +globaliseId :: GlobalIdDetails -> Id -> Id +-- If it's a local, make it global +globaliseId details id = GlobalId { varName = varName id, + realUnique = realUnique id, + idType = idType id, + idInfo = idInfo id, + gblDetails = details } + +lazySetIdInfo :: Id -> IdInfo -> Id +lazySetIdInfo id info = id {idInfo = info} + +setIdInfo :: Id -> IdInfo -> Id +setIdInfo id info = seqIdInfo info `seq` id {idInfo = info} + -- Try to avoid spack leaks by seq'ing + +modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id +modifyIdInfo fn id + = seqIdInfo new_info `seq` id {idInfo = new_info} + where + new_info = fn (idInfo id) + +-- maybeModifyIdInfo tries to avoid unnecesary thrashing +maybeModifyIdInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id +maybeModifyIdInfo fn id + = case fn (idInfo id) of + Nothing -> id + Just new_info -> id {idInfo = new_info} +\end{code} + +%************************************************************************ +%* * +\subsection{Predicates over variables +%* * +%************************************************************************ + +\begin{code} +mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalId details name ty info + = GlobalId { varName = name, + realUnique = getKey# (nameUnique name), -- Cache the unique + idType = ty, + gblDetails = details, + idInfo = info } + +mk_local_id :: Name -> Type -> LocalIdDetails -> IdInfo -> Id +mk_local_id name ty details info + = LocalId { varName = name, + realUnique = getKey# (nameUnique name), -- Cache the unique + idType = ty, + lclDetails = details, + idInfo = info } + +mkLocalId :: Name -> Type -> IdInfo -> Id +mkLocalId name ty info = mk_local_id name ty NotExported info + +mkExportedLocalId :: Name -> Type -> IdInfo -> Id +mkExportedLocalId name ty info = mk_local_id name ty Exported info +\end{code} + +\begin{code} +isTyVar, isTcTyVar :: Var -> Bool +isId, isLocalVar, isLocalId :: Var -> Bool +isGlobalId, isExportedId :: Var -> Bool +mustHaveLocalBinding :: Var -> Bool + +isTyVar (TyVar {}) = True +isTyVar (TcTyVar {}) = True +isTyVar other = False + +isTcTyVar (TcTyVar {}) = True +isTcTyVar other = False + +isId (LocalId {}) = True +isId (GlobalId {}) = True +isId other = False + +isLocalId (LocalId {}) = True +isLocalId other = False + +-- isLocalVar returns True for type variables as well as local Ids +-- These are the variables that we need to pay attention to when finding free +-- variables, or doing dependency analysis. +isLocalVar (GlobalId {}) = False +isLocalVar other = True + +-- mustHaveLocalBinding returns True of Ids and TyVars +-- that must have a binding in this module. The converse +-- is not quite right: there are some GlobalIds that must have +-- bindings, such as record selectors. But that doesn't matter, +-- because it's only used for assertions +mustHaveLocalBinding var = isLocalVar var + +isGlobalId (GlobalId {}) = True +isGlobalId other = False + +-- isExportedId means "don't throw this away" +isExportedId (GlobalId {}) = True +isExportedId (LocalId {lclDetails = details}) + = case details of + Exported -> True + other -> False +isExportedId other = False +\end{code} + +\begin{code} +globalIdDetails :: Var -> GlobalIdDetails +-- Works OK on local Ids too, returning notGlobalId +globalIdDetails (GlobalId {gblDetails = details}) = details +globalIdDetails other = notGlobalId +\end{code} + diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs new file mode 100644 index 0000000000..bfeecdc923 --- /dev/null +++ b/compiler/basicTypes/VarEnv.lhs @@ -0,0 +1,344 @@ + +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section{@VarEnvs@: Variable environments} + +\begin{code} +module VarEnv ( + VarEnv, IdEnv, TyVarEnv, + emptyVarEnv, unitVarEnv, mkVarEnv, + elemVarEnv, varEnvElts, varEnvKeys, + extendVarEnv, extendVarEnv_C, extendVarEnvList, + plusVarEnv, plusVarEnv_C, + delVarEnvList, delVarEnv, + lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, + mapVarEnv, zipVarEnv, + modifyVarEnv, modifyVarEnv_Directly, + isEmptyVarEnv, foldVarEnv, + elemVarEnvByKey, lookupVarEnv_Directly, + filterVarEnv_Directly, + + -- InScopeSet + InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet, + extendInScopeSet, extendInScopeSetList, modifyInScopeSet, + getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, + mapInScopeSet, + + -- RnEnv2 and its operations + RnEnv2, mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR, + rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, + + -- TidyEnvs + TidyEnv, emptyTidyEnv + ) where + +#include "HsVersions.h" + +import OccName ( TidyOccEnv, emptyTidyOccEnv ) +import Var ( Var, setVarUnique ) +import VarSet +import UniqFM +import Unique ( Unique, deriveUnique, getUnique ) +import Util ( zipEqual, foldl2 ) +import Maybes ( orElse, isJust ) +import StaticFlags( opt_PprStyle_Debug ) +import Outputable +import FastTypes +\end{code} + + +%************************************************************************ +%* * + In-scope sets +%* * +%************************************************************************ + +\begin{code} +data InScopeSet = InScope (VarEnv Var) FastInt + -- The Int# is a kind of hash-value used by uniqAway + -- For example, it might be the size of the set + -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway + +instance Outputable InScopeSet where + ppr (InScope s i) = ptext SLIT("InScope") <+> ppr s + +emptyInScopeSet :: InScopeSet +emptyInScopeSet = InScope emptyVarSet 1# + +getInScopeVars :: InScopeSet -> VarEnv Var +getInScopeVars (InScope vs _) = vs + +mkInScopeSet :: VarEnv Var -> InScopeSet +mkInScopeSet in_scope = InScope in_scope 1# + +extendInScopeSet :: InScopeSet -> Var -> InScopeSet +extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#) + +extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet +extendInScopeSetList (InScope in_scope n) vs + = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs) + (n +# iUnbox (length vs)) + +modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet +-- Exploit the fact that the in-scope "set" is really a map +-- Make old_v map to new_v +modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#) + +delInScopeSet :: InScopeSet -> Var -> InScopeSet +delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n + +mapInScopeSet :: (Var -> Var) -> InScopeSet -> InScopeSet +mapInScopeSet f (InScope in_scope n) = InScope (mapVarEnv f in_scope) n + +elemInScopeSet :: Var -> InScopeSet -> Bool +elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope + +lookupInScope :: InScopeSet -> Var -> Maybe Var +-- It's important to look for a fixed point +-- When we see (case x of y { I# v -> ... }) +-- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder). +-- When we lookup up an occurrence of x, we map to y, but then +-- we want to look up y in case it has acquired more evaluation information by now. +lookupInScope (InScope in_scope n) v + = go v + where + go v = case lookupVarEnv in_scope v of + Just v' | v == v' -> Just v' -- Reached a fixed point + | otherwise -> go v' + Nothing -> Nothing +\end{code} + +\begin{code} +uniqAway :: InScopeSet -> Var -> Var +-- (uniqAway in_scope v) finds a unique that is not used in the +-- in-scope set, and gives that to v. It starts with v's current unique, of course, +-- in the hope that it won't have to change it, and thereafter uses a combination +-- of that and the hash-code found in the in-scope set +uniqAway in_scope var + | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one + | otherwise = var -- Nothing to do + +uniqAway' :: InScopeSet -> Var -> Var +-- This one *always* makes up a new variable +uniqAway' (InScope set n) var + = try 1# + where + orig_unique = getUnique var + try k +#ifdef DEBUG + | k ># 1000# + = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) +#endif + | uniq `elemVarSetByKey` set = try (k +# 1#) +#ifdef DEBUG + | opt_PprStyle_Debug && k ># 3# + = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) + setVarUnique var uniq +#endif + | otherwise = setVarUnique var uniq + where + uniq = deriveUnique orig_unique (iBox (n *# k)) +\end{code} + + +%************************************************************************ +%* * + Dual renaming +%* * +%************************************************************************ + +When we are comparing (or matching) types or terms, we are faced with +"going under" corresponding binders. E.g. when comparing + \x. e1 ~ \y. e2 + +Basically we want to rename [x->y] or [y->x], but there are lots of +things we must be careful of. In particular, x might be free in e2, or +y in e1. So the idea is that we come up with a fresh binder that is free +in neither, and rename x and y respectively. That means we must maintain + a) a renaming for the left-hand expression + b) a renaming for the right-hand expressions + c) an in-scope set + +Furthermore, when matching, we want to be able to have an 'occurs check', +to prevent + \x. f ~ \y. y +matching with f->y. So for each expression we want to know that set of +locally-bound variables. That is precisely the domain of the mappings (a) +and (b), but we must ensure that we always extend the mappings as we go in. + + +\begin{code} +data RnEnv2 + = RV2 { envL :: VarEnv Var -- Renaming for Left term + , envR :: VarEnv Var -- Renaming for Right term + , in_scope :: InScopeSet } -- In scope in left or right terms + +-- The renamings envL and envR are *guaranteed* to contain a binding +-- for every variable bound as we go into the term, even if it is not +-- renamed. That way we can ask what variables are locally bound +-- (inRnEnvL, inRnEnvR) + +mkRnEnv2 :: InScopeSet -> RnEnv2 +mkRnEnv2 vars = RV2 { envL = emptyVarEnv + , envR = emptyVarEnv + , in_scope = vars } + +rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 +-- Arg lists must be of equal length +rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR + +rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 +-- (rnBndr2 env bL bR) go under a binder bL in the Left term 1, +-- and binder bR in the Right term +-- It finds a new binder, new_b, +-- and returns an environment mapping bL->new_b and bR->new_b resp. +rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR + = RV2 { envL = extendVarEnv envL bL new_b -- See Note + , envR = extendVarEnv envR bR new_b -- [Rebinding] + , in_scope = extendInScopeSet in_scope new_b } + where + -- Find a new binder not in scope in either term + new_b | not (bL `elemInScopeSet` in_scope) = bL + | not (bR `elemInScopeSet` in_scope) = bR + | otherwise = uniqAway' in_scope bL + + -- Note [Rebinding] + -- If the new var is the same as the old one, note that + -- the extendVarEnv *deletes* any current renaming + -- E.g. (\x. \x. ...) ~ (\y. \z. ...) + -- + -- Inside \x \y { [x->y], [y->y], {y} } + -- \x \z { [x->x], [y->y, z->x], {y,x} } + +rnBndrL, rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- Used when there's a binder on one side or the other only +-- Useful when eta-expanding +rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = envR + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b | not (bL `elemInScopeSet` in_scope) = bL + | otherwise = uniqAway' in_scope bL + +rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envL = envL + , envR = extendVarEnv envR bR new_b + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b | not (bR `elemInScopeSet` in_scope) = bR + | otherwise = uniqAway' in_scope bR + +rnOccL, rnOccR :: RnEnv2 -> Var -> Var +-- Look up the renaming of an occurrence in the left or right term +rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v +rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v + +inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool +-- Tells whether a variable is locally bound +inRnEnvL (RV2 { envL = env }) v = isJust (lookupVarEnv env v) +inRnEnvR (RV2 { envR = env }) v = isJust (lookupVarEnv env v) + +nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 +nukeRnEnvL env = env { envL = emptyVarEnv } +nukeRnEnvR env = env { envR = emptyVarEnv } +\end{code} + + +%************************************************************************ +%* * + Tidying +%* * +%************************************************************************ + +When tidying up print names, we keep a mapping of in-scope occ-names +(the TidyOccEnv) and a Var-to-Var of the current renamings. + +\begin{code} +type TidyEnv = (TidyOccEnv, VarEnv Var) + +emptyTidyEnv :: TidyEnv +emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) +\end{code} + + +%************************************************************************ +%* * +\subsection{@VarEnv@s} +%* * +%************************************************************************ + +\begin{code} +type VarEnv elt = UniqFM elt +type IdEnv elt = VarEnv elt +type TyVarEnv elt = VarEnv elt + +emptyVarEnv :: VarEnv a +mkVarEnv :: [(Var, a)] -> VarEnv a +zipVarEnv :: [Var] -> [a] -> VarEnv a +unitVarEnv :: Var -> a -> VarEnv a +extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a +plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a + +lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a +filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a +delVarEnvList :: VarEnv a -> [Var] -> VarEnv a +delVarEnv :: VarEnv a -> Var -> VarEnv a +plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b +modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a +varEnvElts :: VarEnv a -> [a] +varEnvKeys :: VarEnv a -> [Unique] + +isEmptyVarEnv :: VarEnv a -> Bool +lookupVarEnv :: VarEnv a -> Var -> Maybe a +lookupVarEnv_NF :: VarEnv a -> Var -> a +lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a +elemVarEnv :: Var -> VarEnv a -> Bool +elemVarEnvByKey :: Unique -> VarEnv a -> Bool +foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b +\end{code} + +\begin{code} +elemVarEnv = elemUFM +elemVarEnvByKey = elemUFM_Directly +extendVarEnv = addToUFM +extendVarEnv_C = addToUFM_C +extendVarEnvList = addListToUFM +plusVarEnv_C = plusUFM_C +delVarEnvList = delListFromUFM +delVarEnv = delFromUFM +plusVarEnv = plusUFM +lookupVarEnv = lookupUFM +lookupWithDefaultVarEnv = lookupWithDefaultUFM +mapVarEnv = mapUFM +mkVarEnv = listToUFM +emptyVarEnv = emptyUFM +varEnvElts = eltsUFM +varEnvKeys = keysUFM +unitVarEnv = unitUFM +isEmptyVarEnv = isNullUFM +foldVarEnv = foldUFM +lookupVarEnv_Directly = lookupUFM_Directly +filterVarEnv_Directly = filterUFM_Directly + +zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) +lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx } +\end{code} + +@modifyVarEnv@: Look up a thing in the VarEnv, +then mash it with the modify function, and put it back. + +\begin{code} +modifyVarEnv mangle_fn env key + = case (lookupVarEnv env key) of + Nothing -> env + Just xx -> extendVarEnv env key (mangle_fn xx) + +modifyVarEnv_Directly mangle_fn env key + = case (lookupUFM_Directly env key) of + Nothing -> env + Just xx -> addToUFM_Directly env key (mangle_fn xx) +\end{code} diff --git a/compiler/basicTypes/VarSet.lhs b/compiler/basicTypes/VarSet.lhs new file mode 100644 index 0000000000..55e82a8515 --- /dev/null +++ b/compiler/basicTypes/VarSet.lhs @@ -0,0 +1,105 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section{@VarSet@: Variable sets} + +\begin{code} +module VarSet ( + VarSet, IdSet, TyVarSet, + emptyVarSet, unitVarSet, mkVarSet, + extendVarSet, extendVarSetList, extendVarSet_C, + elemVarSet, varSetElems, subVarSet, + unionVarSet, unionVarSets, + intersectVarSet, intersectsVarSet, + isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, + minusVarSet, foldVarSet, filterVarSet, + lookupVarSet, mapVarSet, sizeVarSet, seqVarSet, + elemVarSetByKey + ) where + +#include "HsVersions.h" + +import Var ( Var, Id, TyVar ) +import Unique ( Unique ) +import UniqSet +import UniqFM ( delFromUFM_Directly, addToUFM_C ) +\end{code} + +%************************************************************************ +%* * +\subsection{@VarSet@s} +%* * +%************************************************************************ + +\begin{code} +type VarSet = UniqSet Var +type IdSet = UniqSet Id +type TyVarSet = UniqSet TyVar + +emptyVarSet :: VarSet +intersectVarSet :: VarSet -> VarSet -> VarSet +unionVarSet :: VarSet -> VarSet -> VarSet +unionVarSets :: [VarSet] -> VarSet +varSetElems :: VarSet -> [Var] +unitVarSet :: Var -> VarSet +extendVarSet :: VarSet -> Var -> VarSet +extendVarSetList:: VarSet -> [Var] -> VarSet +elemVarSet :: Var -> VarSet -> Bool +delVarSet :: VarSet -> Var -> VarSet +delVarSetList :: VarSet -> [Var] -> VarSet +minusVarSet :: VarSet -> VarSet -> VarSet +isEmptyVarSet :: VarSet -> Bool +mkVarSet :: [Var] -> VarSet +foldVarSet :: (Var -> a -> a) -> a -> VarSet -> a +lookupVarSet :: VarSet -> Var -> Maybe Var + -- Returns the set element, which may be + -- (==) to the argument, but not the same as +mapVarSet :: (Var -> Var) -> VarSet -> VarSet +sizeVarSet :: VarSet -> Int +filterVarSet :: (Var -> Bool) -> VarSet -> VarSet +extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet + +delVarSetByKey :: VarSet -> Unique -> VarSet +elemVarSetByKey :: Unique -> VarSet -> Bool + +emptyVarSet = emptyUniqSet +unitVarSet = unitUniqSet +extendVarSet = addOneToUniqSet +extendVarSetList= addListToUniqSet +intersectVarSet = intersectUniqSets + +intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection + -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty +subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second + -- (s1 `subVarSet` s2) doesn't compute s2 if s1 is empty + +unionVarSet = unionUniqSets +unionVarSets = unionManyUniqSets +varSetElems = uniqSetToList +elemVarSet = elementOfUniqSet +minusVarSet = minusUniqSet +delVarSet = delOneFromUniqSet +delVarSetList = delListFromUniqSet +isEmptyVarSet = isEmptyUniqSet +mkVarSet = mkUniqSet +foldVarSet = foldUniqSet +lookupVarSet = lookupUniqSet +mapVarSet = mapUniqSet +sizeVarSet = sizeUniqSet +filterVarSet = filterUniqSet +extendVarSet_C combine s x = addToUFM_C combine s x x +delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet +elemVarSetByKey = elemUniqSet_Directly +\end{code} + +\begin{code} +-- See comments with type signatures +intersectsVarSet s1 s2 = not (isEmptyVarSet (s1 `intersectVarSet` s2)) +a `subVarSet` b = isEmptyVarSet (a `minusVarSet` b) +\end{code} + +\begin{code} +seqVarSet :: VarSet -> () +seqVarSet s = sizeVarSet s `seq` () +\end{code} + |