diff options
| author | Simon Marlow <simonmar@microsoft.com> | 2006-04-07 02:05:11 +0000 |
|---|---|---|
| committer | Simon Marlow <simonmar@microsoft.com> | 2006-04-07 02:05:11 +0000 |
| commit | 0065d5ab628975892cea1ec7303f968c3338cbe1 (patch) | |
| tree | 8e2afe0ab48ee33cf95009809d67c9649573ef92 /compiler/basicTypes | |
| parent | 28a464a75e14cece5db40f2765a29348273ff2d2 (diff) | |
| download | haskell-0065d5ab628975892cea1ec7303f968c3338cbe1.tar.gz | |
Reorganisation of the source tree
Most of the other users of the fptools build system have migrated to
Cabal, and with the move to darcs we can now flatten the source tree
without losing history, so here goes.
The main change is that the ghc/ subdir is gone, and most of what it
contained is now at the top level. The build system now makes no
pretense at being multi-project, it is just the GHC build system.
No doubt this will break many things, and there will be a period of
instability while we fix the dependencies. A straightforward build
should work, but I haven't yet fixed binary/source distributions.
Changes to the Building Guide will follow, too.
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} + |