%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Id]{@Ids@: Value and constructor identifiers}
\begin{code}
-#include "HsVersions.h"
+module Id (
+ Id, DictId, GenId,
-module Id {- (
- GenId, Id(..), -- Abstract
- StrictnessMark(..), -- An enumaration
- ConTag(..), DictVar(..), DictFun(..), DataCon(..),
-
- -- CONSTRUCTION
- mkSysLocal, mkUserLocal,
- mkSpecPragmaId,
- mkSpecId, mkSameSpecCon,
- selectIdInfoForSpecId,
- mkTemplateLocals,
- mkImported,
- mkDataCon, mkTupleCon,
- mkIdWithNewUniq,
- mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
- mkConstMethodId, getConstMethodId,
-
- updateIdType,
- mkId, mkDictFunId, mkInstId,
- mkWorkerId,
- localiseId,
-
- -- DESTRUCTION
- idType,
- getIdInfo, replaceIdInfo,
- getPragmaInfo,
- idPrimRep, getInstIdModule,
- getMentionedTyConsAndClassesFromId,
-
- dataConTag, dataConStrictMarks,
- dataConSig, dataConRawArgTys, dataConArgTys,
- dataConTyCon, dataConArity,
- dataConFieldLabels,
+ -- Simple construction
+ mkVanillaId, mkImportedId, mkSysLocal, mkUserLocal,
+ mkTemplateLocals, mkWildId, mkUserId,
+ -- Taking an Id apart
+ idName, idType, idUnique, idInfo,
+ idPrimRep, isId,
recordSelectorFieldLabel,
- -- PREDICATES
- isDataCon, isTupleCon,
- isNullaryDataCon,
- isSpecId_maybe, isSpecPragmaId_maybe,
- toplevelishId, externallyVisibleId,
- isTopLevId, isWorkerId, isWrapperId,
- isImportedId, isSysLocalId,
- isBottomingId,
- isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
- isDictFunId,
---??? isInstId_maybe,
- isConstMethodId_maybe,
- cmpId_withSpecDataCon,
- myWrapperMaybe,
- whatsMentionedInId,
- unfoldingUnfriendlyId, -- ToDo: rm, eventually
- idWantsToBeINLINEd,
--- dataConMentionsNonPreludeTyCon,
-
- -- SUBSTITUTION
- applySubstToId, applyTypeEnvToId,
--- not exported: apply_to_Id, -- please don't use this, generally
-
- -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
- getIdArity, addIdArity,
- getIdDemandInfo, addIdDemandInfo,
- getIdSpecialisation, addIdSpecialisation,
- getIdStrictness, addIdStrictness,
- getIdUnfolding, addIdUnfolding,
- getIdUpdateInfo, addIdUpdateInfo,
- getIdArgUsageInfo, addIdArgUsageInfo,
- getIdFBTypeInfo, addIdFBTypeInfo,
- -- don't export the types, lest OptIdInfo be dragged in!
-
- -- MISCELLANEOUS
- unlocaliseId,
- fIRST_TAG,
- showId,
- pprIdInUnfolding,
-
- nmbrId,
-
- -- "Environments" keyed off of Ids, and sets of Ids
- IdEnv(..),
- lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
- growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
- delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
- rngIdEnv, mapIdEnv,
-
- -- and to make the interface self-sufficient...
- GenIdSet(..), IdSet(..)
- )-} where
-
-IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) -- for paranoia checking
-IMPORT_DELOOPER(TyLoop) -- for paranoia checking
-
-import Bag
-import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
-import CStrings ( identToC, cSEP )
-import IdInfo
-import Maybes ( maybeToBool )
-import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
- isLocallyDefinedName,
- mkTupleDataConName, mkCompoundName, mkCompoundName2,
- isLexSym, isLexSpecialSym,
- isLocallyDefined, changeUnique,
- getOccName, origName, moduleOf,
- isExported, ExportFlag(..),
- RdrName(..), Name
- )
-import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
-import PragmaInfo ( PragmaInfo(..) )
-import PprEnv -- ( NmbrM(..), NmbrEnv(..) )
-import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
- nmbrType, nmbrTyVar,
- GenType, GenTyVar
- )
-import PprStyle
-import Pretty
-import SrcLoc ( mkBuiltinSrcLoc )
-import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
-import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
- applyTyCon, isPrimType, instantiateTy,
- tyVarsOfType, applyTypeEnvToTy, typePrimRep,
- GenType, ThetaType(..), TauType(..), Type(..)
- )
-import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
-import UniqFM
-import UniqSet -- practically all of it
-import Unique ( getBuiltinUniques, pprUnique, showUnique,
- incrUnique,
- Unique{-instance Ord3-}
- )
-import Util ( mapAccumL, nOfThem, zipEqual,
- panic, panic#, pprPanic, assertPanic
- )
-\end{code}
-
-Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
-follow.
+ -- Modifying an Id
+ setIdName, setIdUnique, setIdType, setIdInfo,
+ setIdVisibility, mkIdVisible,
+
+ -- Predicates
+ omitIfaceSigForId,
+ externallyVisibleId,
+ idFreeTyVars,
+
+ -- Inline pragma stuff
+ getInlinePragma, setInlinePragma, modifyInlinePragma,
+ idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
+ isSpecPragmaId,
+
+
+ isRecordSelector,
+ isPrimitiveId_maybe, isDataConId_maybe,
+ isConstantId,
+ isBottomingId,
+
+ -- IdInfo stuff
+ setIdUnfolding,
+ setIdArity,
+ setIdDemandInfo,
+ setIdStrictness,
+ setIdSpecialisation,
+ setIdUpdateInfo,
+ setIdCafInfo,
+
+ getIdArity,
+ getIdDemandInfo,
+ getIdStrictness,
+ getIdUnfolding,
+ getIdSpecialisation,
+ getIdUpdateInfo,
+ getIdCafInfo
+
+ ) where
-Every @Id@ 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 @Ids@ is
-in its @IdDetails@.
+#include "HsVersions.h"
-ToDo: possibly cache other stuff in the single-constructor @Id@ type.
+import {-# SOURCE #-} CoreUnfold ( Unfolding )
-\begin{code}
-data GenId ty = Id
- Unique -- Key for fast comparison
- Name
- ty -- Id's type; used all the time;
- IdDetails -- Stuff about individual kinds of Ids.
- PragmaInfo -- Properties of this Id requested by programmer
- -- eg specialise-me, inline-me
- IdInfo -- Properties of this Id deduced by compiler
-
-type Id = GenId Type
-
-data StrictnessMark = MarkedStrict | NotMarkedStrict
-
-data IdDetails
-
- ---------------- Local values
-
- = LocalId Bool -- Local name; mentioned by the user
- -- True <=> no free type vars
-
- | SysLocalId Bool -- Local name; made up by the compiler
- -- as for LocalId
-
- | SpecPragmaId -- Local name; introduced by the compiler
- (Maybe Id) -- for explicit specid in pragma
- Bool -- as for LocalId
-
- ---------------- Global values
-
- | ImportedId -- Global name (Imported or Implicit); Id imported from an interface
-
- | TopLevId -- Global name (LocalDef); Top-level in the orig source pgm
- -- (not moved there by transformations).
-
- -- a TopLevId's type may contain free type variables, if
- -- the monomorphism restriction applies.
-
- ---------------- Data constructors
-
- | DataConId ConTag
- [StrictnessMark] -- Strict args; length = arity
- [FieldLabel] -- Field labels for this constructor
-
- [TyVar] [(Class,Type)] [Type] TyCon
- -- the type is:
- -- forall tyvars . theta_ty =>
- -- unitype_1 -> ... -> unitype_n -> tycon tyvars
-
- | TupleConId Int -- Its arity
-
- | RecordSelId FieldLabel
-
- ---------------- Things to do with overloading
-
- | SuperDictSelId -- Selector for superclass dictionary
- Class -- The class (input dict)
- Class -- The superclass (result dict)
-
- | MethodSelId Class -- An overloaded class operation, with
- -- a fully polymorphic type. Its code
- -- just selects a method from the
- -- dictionary. The class.
- ClassOp -- The operation
-
- -- NB: The IdInfo for a MethodSelId has all the info about its
- -- related "constant method Ids", which are just
- -- specialisations of this general one.
-
- | DefaultMethodId -- Default method for a particular class op
- Class -- same class, <blah-blah> info as MethodSelId
- ClassOp -- (surprise, surprise)
- Bool -- True <=> I *know* this default method Id
- -- is a generated one that just says
- -- `error "No default method for <op>"'.
-
- -- see below
- | DictFunId Class -- A DictFun is uniquely identified
- Type -- by its class and type; this type has free type vars,
- -- whose identity is irrelevant. Eg Class = Eq
- -- Type = Tree a
- -- The "a" is irrelevant. As it is too painful to
- -- actually do comparisons that way, we kindly supply
- -- a Unique for that purpose.
- Module -- module where instance came from
-
- -- see below
- | ConstMethodId -- A method which depends only on the type of the
- -- instance, and not on any further dictionaries etc.
- Class -- Uniquely identified by:
- Type -- (class, type, classop) triple
- ClassOp
- Module -- module where instance came from
-
- | InstId -- An instance of a dictionary, class operation,
- -- or overloaded value (Local name)
- Bool -- as for LocalId
-
- | SpecId -- A specialisation of another Id
- Id -- Id of which this is a specialisation
- [Maybe Type] -- Types at which it is specialised;
- -- A "Nothing" says this type ain't relevant.
- Bool -- True <=> no free type vars; it's not enough
- -- to know about the unspec version, because
- -- we may specialise to a type w/ free tyvars
- -- (i.e., in one of the "Maybe Type" dudes).
-
- | WorkerId -- A "worker" for some other Id
- Id -- Id for which this is a worker
-
-type ConTag = Int
-type DictVar = Id
-type DictFun = Id
-type DataCon = Id
+import Var ( Id, GenId, DictId, VarDetails(..),
+ isId, mkId,
+ idName, idType, idUnique, idInfo, varDetails,
+ setIdName, setVarType, setIdUnique, setIdInfo, modifyIdInfo,
+ externallyVisibleId
+ )
+import VarSet
+import Type ( GenType, Type, tyVarsOfType, typePrimRep, addFreeTyVars )
+import IdInfo
+import Demand ( Demand )
+import Name ( Name, OccName,
+ mkSysLocalName, mkLocalName,
+ isWiredInName, setNameVisibility, mkNameVisible
+ )
+import Const ( Con(..) )
+import PrimRep ( PrimRep )
+import PrimOp ( PrimOp )
+import FieldLabel ( FieldLabel(..) )
+import BasicTypes ( Module )
+import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques )
+import Outputable
+
+infixl 1 `setIdUnfolding`,
+ `setIdArity`,
+ `setIdDemandInfo`,
+ `setIdStrictness`,
+ `setIdSpecialisation`,
+ `setIdUpdateInfo`,
+ `setInlinePragma`
+ -- infixl so you can say (id `set` a `set` b)
\end{code}
-DictFunIds are generated from instance decls.
-\begin{verbatim}
- class Foo a where
- op :: a -> a -> Bool
-
- instance Foo a => Foo [a] where
- op = ...
-\end{verbatim}
-generates the dict fun id decl
-\begin{verbatim}
- dfun.Foo.[*] = \d -> ...
-\end{verbatim}
-The dfun id is uniquely named by the (class, type) pair. Notice, it
-isn't a (class,tycon) pair any more, because we may get manually or
-automatically generated specialisations of the instance decl:
-\begin{verbatim}
- instance Foo [Int] where
- op = ...
-\end{verbatim}
-generates
-\begin{verbatim}
- dfun.Foo.[Int] = ...
-\end{verbatim}
-The type variables in the name are irrelevant; we print them as stars.
-
-
-Constant method ids are generated from instance decls where
-there is no context; that is, no dictionaries are needed to
-construct the method. Example
-\begin{verbatim}
- instance Foo Int where
- op = ...
-\end{verbatim}
-Then we get a constant method
-\begin{verbatim}
- Foo.op.Int = ...
-\end{verbatim}
-
-It is possible, albeit unusual, to have a constant method
-for an instance decl which has type vars:
-\begin{verbatim}
- instance Foo [a] where
- op [] ys = True
- op (x:xs) ys = False
-\end{verbatim}
-We get the constant method
-\begin{verbatim}
- Foo.op.[*] = ...
-\end{verbatim}
-So a constant method is identified by a class/op/type triple.
-The type variables in the type are irrelevant.
-
-
-For Ids whose names must be known/deducible in other modules, we have
-to conjure up their worker's names (and their worker's worker's
-names... etc) in a known systematic way.
%************************************************************************
%* *
-\subsection[Id-documentation]{Documentation}
+\subsection{Simple Id construction}
%* *
%************************************************************************
-[A BIT DATED [WDP]]
-
-The @Id@ datatype describes {\em values}. The basic things we want to
-know: (1)~a value's {\em type} (@idType@ is a very common
-operation in the compiler); and (2)~what ``flavour'' of value it might
-be---for example, it can be terribly useful to know that a value is a
-class method.
-
-\begin{description}
-%----------------------------------------------------------------------
-\item[@DataConId@:] For the data constructors declared by a @data@
-declaration. Their type is kept in {\em two} forms---as a regular
-@Type@ (in the usual place), and also in its constituent pieces (in
-the ``details''). We are frequently interested in those pieces.
-
-%----------------------------------------------------------------------
-\item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
-the infinite family of tuples.
-
-%----------------------------------------------------------------------
-\item[@ImportedId@:] These are values defined outside this module.
-{\em Everything} we want to know about them must be stored here (or in
-their @IdInfo@).
-
-%----------------------------------------------------------------------
-\item[@TopLevId@:] These are values defined at the top-level in this
-module; i.e., those which {\em might} be exported (hence, a
-@Name@). It does {\em not} include those which are moved to the
-top-level through program transformations.
-
-We also guarantee that @TopLevIds@ will {\em stay} at top-level.
-Theoretically, they could be floated inwards, but there's no known
-advantage in doing so. This way, we can keep them with the same
-@Unique@ throughout (no cloning), and, in general, we don't have to be
-so paranoid about them.
-
-In particular, we had the following problem generating an interface:
-We have to ``stitch together'' info (1)~from the typechecker-produced
-global-values list (GVE) and (2)~from the STG code [which @Ids@ have
-what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change}
-between (1) and (2), you're sunk!
-
-%----------------------------------------------------------------------
-\item[@MethodSelId@:] A selector from a dictionary; it may select either
-a method or a dictionary for one of the class's superclasses.
-
-%----------------------------------------------------------------------
-\item[@DictFunId@:]
-
-@mkDictFunId [a,b..] theta C T@ is the function derived from the
-instance declaration
-
- instance theta => C (T a b ..) where
- ...
-
-It builds function @Id@ which maps dictionaries for theta,
-to a dictionary for C (T a b ..).
-
-*Note* that with the ``Mark Jones optimisation'', the theta may
-include dictionaries for the immediate superclasses of C at the type
-(T a b ..).
-
-%----------------------------------------------------------------------
-\item[@InstId@:]
-
-%----------------------------------------------------------------------
-\item[@SpecId@:]
-
-%----------------------------------------------------------------------
-\item[@WorkerId@:]
-
-%----------------------------------------------------------------------
-\item[@LocalId@:] A purely-local value, e.g., a function argument,
-something defined in a @where@ clauses, ... --- but which appears in
-the original program text.
-
-%----------------------------------------------------------------------
-\item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
-the original program text; these are introduced by the compiler in
-doing its thing.
-
-%----------------------------------------------------------------------
-\item[@SpecPragmaId@:] Introduced by the compiler to record
-Specialisation pragmas. It is dead code which MUST NOT be removed
-before specialisation.
-\end{description}
-
-Further remarks:
-\begin{enumerate}
-%----------------------------------------------------------------------
-\item
-
-@DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
-@MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
-properties:
-\begin{itemize}
-\item
-They have no free type variables, so if you are making a
-type-variable substitution you don't need to look inside them.
-\item
-They are constants, so they are not free variables. (When the STG
-machine makes a closure, it puts all the free variables in the
-closure; the above are not required.)
-\end{itemize}
-Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
-properties, but they may not.
-\end{enumerate}
-
-%************************************************************************
-%* *
-\subsection[Id-general-funs]{General @Id@-related functions}
-%* *
-%************************************************************************
-
-\begin{code}
-unsafeGenId2Id :: GenId ty -> Id
-unsafeGenId2Id (Id u n ty d p i) = Id u n (panic "unsafeGenId2Id:ty") d p i
-
-isDataCon id = is_data (unsafeGenId2Id id)
- where
- is_data (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
- is_data (Id _ _ _ (TupleConId _) _ _) = True
- is_data (Id _ _ _ (SpecId unspec _ _) _ _) = is_data unspec
- is_data other = False
-
-
-isTupleCon id = is_tuple (unsafeGenId2Id id)
- where
- is_tuple (Id _ _ _ (TupleConId _) _ _) = True
- is_tuple (Id _ _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
- is_tuple other = False
-
-{-LATER:
-isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _)
- = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
- Just (unspec, ty_maybes)
-isSpecId_maybe other_id
- = Nothing
-
-isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId specid _) _ _)
- = Just specid
-isSpecPragmaId_maybe other_id
- = Nothing
--}
-\end{code}
-
-@toplevelishId@ tells whether an @Id@ {\em may} be defined in a nested
-@let(rec)@ (returns @False@), or whether it is {\em sure} to be
-defined at top level (returns @True@). This is used to decide whether
-the @Id@ is a candidate free variable. NB: you are only {\em sure}
-about something if it returns @True@!
-
-\begin{code}
-toplevelishId :: Id -> Bool
-idHasNoFreeTyVars :: Id -> Bool
-
-toplevelishId (Id _ _ _ details _ _)
- = chk details
- where
- chk (DataConId _ _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (RecordSelId _) = True
- chk ImportedId = True
- chk TopLevId = True -- NB: see notes
- chk (SuperDictSelId _ _) = True
- chk (MethodSelId _ _) = True
- chk (DefaultMethodId _ _ _) = True
- chk (DictFunId _ _ _) = True
- chk (ConstMethodId _ _ _ _) = True
- chk (SpecId unspec _ _) = toplevelishId unspec
- -- depends what the unspecialised thing is
- chk (WorkerId unwrkr) = toplevelishId unwrkr
- chk (InstId _) = False -- these are local
- chk (LocalId _) = False
- chk (SysLocalId _) = False
- chk (SpecPragmaId _ _) = False
-
-idHasNoFreeTyVars (Id _ _ _ details _ info)
- = chk details
- where
- chk (DataConId _ _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (RecordSelId _) = True
- chk ImportedId = True
- chk TopLevId = True
- chk (SuperDictSelId _ _) = True
- chk (MethodSelId _ _) = True
- chk (DefaultMethodId _ _ _) = True
- chk (DictFunId _ _ _) = True
- chk (ConstMethodId _ _ _ _) = True
- chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
- chk (SpecId _ _ no_free_tvs) = no_free_tvs
- chk (InstId no_free_tvs) = no_free_tvs
- chk (LocalId no_free_tvs) = no_free_tvs
- chk (SysLocalId no_free_tvs) = no_free_tvs
- chk (SpecPragmaId _ no_free_tvs) = no_free_tvs
-\end{code}
-
-\begin{code}
-isTopLevId (Id _ _ _ TopLevId _ _) = True
-isTopLevId other = False
-
-isImportedId (Id _ _ _ ImportedId _ _) = True
-isImportedId other = False
-
-isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
-
-isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True
-isSysLocalId other = False
-
-isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True
-isSpecPragmaId other = False
-
-isMethodSelId (Id _ _ _ (MethodSelId _ _) _ _) = True
-isMethodSelId _ = False
-
-isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
-isDefaultMethodId other = False
-
-isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _)
- = Just (cls, clsop, err)
-isDefaultMethodId_maybe other = Nothing
-
-isDictFunId (Id _ _ _ (DictFunId _ _ _) _ _) = True
-isDictFunId other = False
-
-isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True
-isConstMethodId other = False
-
-isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _) _ _)
- = Just (cls, ty, clsop)
-isConstMethodId_maybe other = Nothing
-
-isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
-isSuperDictSelId_maybe other_id = Nothing
-
-isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
-isWorkerId other = False
-
-{-LATER:
-isWrapperId id = workerExists (getIdStrictness id)
--}
-\end{code}
-
-\begin{code}
-{-LATER:
-pprIdInUnfolding :: IdSet -> Id -> Pretty
-
-pprIdInUnfolding in_scopes v
- = let
- v_ty = idType v
- in
- -- local vars first:
- if v `elementOfUniqSet` in_scopes then
- pprUnique (idUnique v)
-
- -- ubiquitous Ids with special syntax:
- else if v == nilDataCon then
- ppPStr SLIT("_NIL_")
- else if isTupleCon v then
- ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
-
- -- ones to think about:
- else
- let
- (Id _ _ _ v_details _ _) = v
- in
- case v_details of
- -- these ones must have been exported by their original module
- ImportedId -> pp_full_name
-
- -- these ones' exportedness checked later...
- TopLevId -> pp_full_name
- DataConId _ _ _ _ _ _ _ -> pp_full_name
-
- RecordSelId lbl -> ppr sty lbl
-
- -- class-ish things: class already recorded as "mentioned"
- SuperDictSelId c sc
- -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
- MethodSelId c o
- -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
- DefaultMethodId c o _
- -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
-
- -- instance-ish things: should we try to figure out
- -- *exactly* which extra instances have to be exported? (ToDo)
- DictFunId c t _
- -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
- ConstMethodId c t o _
- -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
-
- -- specialisations and workers
- SpecId unspec ty_maybes _
- -> let
- pp = pprIdInUnfolding in_scopes unspec
- in
- ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
- ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
- ppRbrack]
-
- WorkerId unwrkr
- -> let
- pp = pprIdInUnfolding in_scopes unwrkr
- in
- ppBeside (ppPStr SLIT("_WRKR_ ")) pp
-
- -- anything else? we're nae interested
- other_id -> panic "pprIdInUnfolding:mystery Id"
- where
- ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
-
- pp_full_name
- = let
- (OrigName m_str n_str) = origName "Id:ppr_Unfolding" v
-
- pp_n =
- if isLexSym n_str && not (isLexSpecialSym n_str) then
- ppBesides [ppLparen, ppPStr n_str, ppRparen]
- else
- ppPStr n_str
- in
- if isPreludeDefined v then
- pp_n
- else
- ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
-
- pp_class :: Class -> Pretty
- pp_class_op :: ClassOp -> Pretty
- pp_type :: Type -> Pretty
- pp_ty_maybe :: Maybe Type -> Pretty
-
- pp_class clas = ppr ppr_Unfolding clas
- pp_class_op op = ppr ppr_Unfolding op
-
- pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
-
- pp_ty_maybe Nothing = ppPStr SLIT("_N_")
- pp_ty_maybe (Just t) = pp_type t
--}
-\end{code}
-
-@whatsMentionedInId@ ferrets out the types/classes/instances on which
-this @Id@ depends. If this Id is to appear in an interface, then
-those entities had Jolly Well be in scope. Someone else up the
-call-tree decides that.
-
-\begin{code}
-{-LATER:
-whatsMentionedInId
- :: IdSet -- Ids known to be in scope
- -> Id -- Id being processed
- -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
-
-whatsMentionedInId in_scopes v
- = let
- v_ty = idType v
-
- (tycons, clss)
- = getMentionedTyConsAndClassesFromType v_ty
-
- result0 id_bag = (id_bag, tycons, clss)
-
- result1 ids tcs cs
- = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
- tcs `unionBags` tycons,
- cs `unionBags` clss)
- in
- -- local vars first:
- if v `elementOfUniqSet` in_scopes then
- result0 emptyBag -- v not added to "mentioned"
-
- -- ones to think about:
- else
- let
- (Id _ _ _ v_details _ _) = v
- in
- case v_details of
- -- specialisations and workers
- SpecId unspec ty_maybes _
- -> let
- (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
- in
- result1 ids2 tcs2 cs2
-
- WorkerId unwrkr
- -> let
- (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
- in
- result1 ids2 tcs2 cs2
-
- anything_else -> result0 (unitBag v) -- v is added to "mentioned"
--}
-\end{code}
-
-Tell them who my wrapper function is.
-\begin{code}
-{-LATER:
-myWrapperMaybe :: Id -> Maybe Id
-
-myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
-myWrapperMaybe other_id = Nothing
--}
-\end{code}
-
-\begin{code}
-unfoldingUnfriendlyId -- return True iff it is definitely a bad
- :: Id -- idea to export an unfolding that
- -> Bool -- mentions this Id. Reason: it cannot
- -- possibly be seen in another module.
-
-unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
-{-LATER:
-
-unfoldingUnfriendlyId id
- | not (externallyVisibleId id) -- that settles that...
- = True
-
-unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper) _ _)
- = class_thing wrapper
- where
- -- "class thing": If we're going to use this worker Id in
- -- an interface, we *have* to be able to untangle the wrapper's
- -- strictness when reading it back in. At the moment, this
- -- is not always possible: in precisely those cases where
- -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
-
- class_thing (Id _ _ _ (SuperDictSelId _ _) _ _) = True
- class_thing (Id _ _ _ (MethodSelId _ _) _ _) = True
- class_thing (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
- class_thing other = False
-
-unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _) _ _)
- -- a SPEC of a DictFunId can end up w/ gratuitous
- -- TyVar(Templates) in the i/face; only a problem
- -- if -fshow-pragma-name-errs; but we can do without the pain.
- -- A HACK in any case (WDP 94/05/02)
- = naughty_DictFunId dfun
-
-unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _) _ _)
- = naughty_DictFunId dfun -- similar deal...
-
-unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
-
-naughty_DictFunId :: IdDetails -> Bool
- -- True <=> has a TyVar(Template) in the "type" part of its "name"
-
-naughty_DictFunId (DictFunId _ _ _) = panic "False" -- came from outside; must be OK
-naughty_DictFunId (DictFunId _ ty _)
- = not (isGroundTy ty)
--}
-\end{code}
-
-@externallyVisibleId@: is it true that another module might be
-able to ``see'' this Id?
-
-We need the @toplevelishId@ check as well as @isExported@ for when we
-compile instance declarations in the prelude. @DictFunIds@ are
-``exported'' if either their class or tycon is exported, but, in
-compiling the prelude, the compiler may not recognise that as true.
-
\begin{code}
-externallyVisibleId :: Id -> Bool
-
-externallyVisibleId id@(Id _ _ _ details _ _)
- = if isLocallyDefined id then
- toplevelishId id && isExported id && not (weird_datacon details)
- else
- not (weird_tuplecon details)
- -- if visible here, it must be visible elsewhere, too.
- where
- -- If it's a DataCon, it's not enough to know it (meaning
- -- its TyCon) is exported; we need to know that it might
- -- be visible outside. Consider:
- --
- -- data Foo a = Mumble | BigFoo a WeirdLocalType
- --
- -- We can't tell the outside world *anything* about Foo, because
- -- of WeirdLocalType; but we need to know this when asked if
- -- "Mumble" is externally visible...
-
-{- LATER: if at all:
- weird_datacon (DataConId _ _ _ _ _ _ tycon)
- = maybeToBool (maybePurelyLocalTyCon tycon)
--}
- weird_datacon not_a_datacon_therefore_not_weird = False
-
- weird_tuplecon (TupleConId arity)
- = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
- weird_tuplecon _ = False
-\end{code}
+mkVanillaId :: Name -> (GenType flexi) -> GenId flexi
+mkVanillaId name ty = mkId name ty VanillaId noIdInfo
-\begin{code}
-idWantsToBeINLINEd :: Id -> Bool
+mkImportedId :: Name -> Type -> IdInfo -> Id
+mkImportedId name ty info = mkId name ty VanillaId info
-idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
-idWantsToBeINLINEd _ = False
-\end{code}
+mkUserId :: Name -> GenType flexi -> GenId flexi
+mkUserId name ty = mkVanillaId name ty
-For @unlocaliseId@: See the brief commentary in
-\tr{simplStg/SimplStg.lhs}.
+-- 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 -> GenType flexi -> GenId flexi
+mkSysLocal :: Unique -> GenType flexi -> GenId flexi
-\begin{code}
-{-LATER:
-unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
-
-unlocaliseId mod (Id u fn ty info TopLevId)
- = Just (Id u (unlocaliseFullName fn) ty info TopLevId)
-
-unlocaliseId mod (Id u sn ty info (LocalId no_ftvs))
- = --false?: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod u sn
- in
- Just (Id u full_name ty info TopLevId)
-
-unlocaliseId mod (Id u sn ty info (SysLocalId no_ftvs))
- = --false?: on PreludeGlaST: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod u sn
- in
- Just (Id u full_name ty info TopLevId)
-
-unlocaliseId mod (Id u n ty info (SpecId unspec ty_maybes no_ftvs))
- = case unlocalise_parent mod u unspec of
- Nothing -> Nothing
- Just xx -> Just (Id u n ty info (SpecId xx ty_maybes no_ftvs))
-
-unlocaliseId mod (Id u n ty info (WorkerId unwrkr))
- = case unlocalise_parent mod u unwrkr of
- Nothing -> Nothing
- Just xx -> Just (Id u n ty info (WorkerId xx))
-
-unlocaliseId mod (Id u name ty info (InstId no_ftvs))
- = Just (Id u full_name ty info TopLevId)
- -- type might be wrong, but it hardly matters
- -- at this stage (just before printing C) ToDo
- where
- name = nameOf (origName "Id.unlocaliseId" name)
- full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
-
-unlocaliseId mod other_id = Nothing
-
---------------------
--- we have to be Very Careful for workers/specs of
--- local functions!
-
-unlocalise_parent mod uniq (Id _ sn ty info (LocalId no_ftvs))
- = --false?: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod uniq sn
- in
- Just (Id uniq full_name ty info TopLevId)
-
-unlocalise_parent mod uniq (Id _ sn ty info (SysLocalId no_ftvs))
- = --false?: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod uniq sn
- in
- Just (Id uniq full_name ty info TopLevId)
-
-unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
- -- we're OK otherwise
--}
+mkSysLocal uniq ty = mkVanillaId (mkSysLocalName uniq) ty
+mkUserLocal occ uniq ty = mkVanillaId (mkLocalName uniq occ) ty
\end{code}
-CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
-`Top-levelish Ids'' cannot have any free type variables, so applying
-the type-env cannot have any effect. (NB: checked in CoreLint?)
-
-The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
-former ``should be'' the usual crunch point.
+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}
-type TypeEnv = TyVarEnv Type
-
-applyTypeEnvToId :: TypeEnv -> Id -> Id
+-- "Wild Id" typically used when you need a binder that you don't expect to use
+mkWildId :: Type -> Id
+mkWildId ty = mkSysLocal (mkBuiltinUnique 1) ty
-applyTypeEnvToId type_env id@(Id _ _ ty _ _ _)
- | idHasNoFreeTyVars id
- = id
- | otherwise
- = apply_to_Id ( \ ty ->
- applyTypeEnvToTy type_env ty
- ) id
-\end{code}
-
-\begin{code}
-apply_to_Id :: (Type -> Type) -> Id -> Id
-
-apply_to_Id ty_fn (Id u n ty details prag info)
- = let
- new_ty = ty_fn ty
- in
- Id u n new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
- where
- apply_to_details (SpecId unspec ty_maybes no_ftvs)
- = let
- new_unspec = apply_to_Id ty_fn unspec
- new_maybes = map apply_to_maybe ty_maybes
- in
- SpecId new_unspec new_maybes (no_free_tvs ty)
- -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
- where
- apply_to_maybe Nothing = Nothing
- apply_to_maybe (Just ty) = Just (ty_fn ty)
-
- apply_to_details (WorkerId unwrkr)
- = let
- new_unwrkr = apply_to_Id ty_fn unwrkr
- in
- WorkerId new_unwrkr
-
- apply_to_details other = other
+-- "Template locals" typically used in unfoldings
+mkTemplateLocals :: [Type] -> [Id]
+mkTemplateLocals tys = zipWith mkSysLocal
+ (getBuiltinUniques (length tys))
+ tys
\end{code}
-Sadly, I don't think the one using the magic typechecker substitution
-can be done with @apply_to_Id@. Here we go....
-
-Strictness is very important here. We can't leave behind thunks
-with pointers to the substitution: it {\em must} be single-threaded.
-
-\begin{code}
-{-LATER:
-applySubstToId :: Subst -> Id -> (Subst, Id)
-
-applySubstToId subst id@(Id u n ty info details)
- -- *cannot* have a "idHasNoFreeTyVars" get-out clause
- -- because, in the typechecker, we are still
- -- *concocting* the types.
- = case (applySubstToTy subst ty) of { (s2, new_ty) ->
- case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
- case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
- (s4, Id u n new_ty new_info new_details) }}}
- where
- apply_to_details subst _ (InstId inst no_ftvs)
- = case (applySubstToInst subst inst) of { (s2, new_inst) ->
- (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
-
- apply_to_details subst new_ty (SpecId unspec ty_maybes _)
- = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
- case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
- (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
- -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
- where
- apply_to_maybe subst Nothing = (subst, Nothing)
- apply_to_maybe subst (Just ty)
- = case (applySubstToTy subst ty) of { (s2, new_ty) ->
- (s2, Just new_ty) }
-
- apply_to_details subst _ (WorkerId unwrkr)
- = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
- (s2, WorkerId new_unwrkr) }
-
- apply_to_details subst _ other = (subst, other)
--}
-\end{code}
%************************************************************************
%* *
-\subsection[Id-type-funs]{Type-related @Id@ functions}
+\subsection[Id-general-funs]{General @Id@-related functions}
%* *
%************************************************************************
\begin{code}
-idType :: GenId ty -> ty
+idFreeTyVars :: (GenId flexi) -> (GenTyVarSet flexi)
+idFreeTyVars id = tyVarsOfType (idType id)
-idType (Id _ _ ty _ _ _) = ty
-\end{code}
-
-\begin{code}
-{-LATER:
-getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
+setIdType :: GenId flexi1 -> GenType flexi2 -> GenId flexi2
+ -- Add free tyvar info to the type
+setIdType id ty = setVarType id (addFreeTyVars ty)
-getMentionedTyConsAndClassesFromId id
- = getMentionedTyConsAndClassesFromType (idType id)
--}
+idPrimRep :: Id -> PrimRep
+idPrimRep id = typePrimRep (idType id)
\end{code}
-\begin{code}
-idPrimRep i = typePrimRep (idType i)
-\end{code}
+omitIfaceSigForId 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.
\begin{code}
-{-LATER:
-getInstIdModule (Id _ _ _ (DictFunId _ _ mod)) = mod
-getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ mod)) = mod
-getInstIdModule other = panic "Id:getInstIdModule"
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Id-overloading]{Functions related to overloading}
-%* *
-%************************************************************************
-
-\begin{code}
-mkSuperDictSelId u c sc ty info
- = mk_classy_id (SuperDictSelId c sc) SLIT("sdsel") (Left (origName "mkSuperDictSelId" sc)) u c ty info
-
-mkMethodSelId u rec_c op ty info
- = mk_classy_id (MethodSelId rec_c op) SLIT("meth") (Right (classOpString op)) u rec_c ty info
-
-mkDefaultMethodId u rec_c op gen ty info
- = mk_classy_id (DefaultMethodId rec_c op gen) SLIT("defm") (Right (classOpString op)) u rec_c ty info
-
-mk_classy_id details str op_str u rec_c ty info
- = Id u n ty details NoPragmaInfo info
- where
- cname = getName rec_c -- we get other info out of here
- cname_orig = origName "mk_classy_id" cname
- cmod = moduleOf cname_orig
-
- n = mkCompoundName u cmod str [Left cname_orig, op_str] cname
-
-mkDictFunId u c ity full_ty from_here locn mod info
- = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info
- where
- n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : map Right (getTypeString ity)) from_here locn
-
-mkConstMethodId u c op ity full_ty from_here locn mod info
- = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info
- where
- n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : map Right (getTypeString ity)) from_here locn
-
-mkWorkerId u unwrkr ty info
- = Id u n ty (WorkerId unwrkr) NoPragmaInfo info
- where
- unwrkr_name = getName unwrkr
- unwrkr_orig = trace "mkWorkerId:origName:" $ origName "mkWorkerId" unwrkr_name
- umod = moduleOf unwrkr_orig
-
- n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name
-
-mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
-
-{-LATER:
-getConstMethodId clas op ty
- = -- constant-method info is hidden in the IdInfo of
- -- the class-op id (as mentioned up above).
- let
- sel_id = getMethodSelId clas op
- in
- case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
- Just xx -> xx
- Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
- ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
- ppr PprDebug sel_id],
- ppStr "(This can arise if an interface pragma refers to an instance",
- ppStr "but there is no imported interface which *defines* that instance.",
- ppStr "The info above, however ugly, should indicate what else you need to import."
- ])
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[local-funs]{@LocalId@-related functions}
-%* *
-%************************************************************************
-
-\begin{code}
-mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
-
-{-LATER:
-updateIdType :: Id -> Type -> Id
-updateIdType (Id u n _ info details) ty = Id u n ty info details
--}
-\end{code}
-
-\begin{code}
-type MyTy a b = GenType (GenTyVar a) b
-type MyId a b = GenId (MyTy a b)
-
-no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
-
--- SysLocal: for an Id being created by the compiler out of thin air...
--- UserLocal: an Id with a name the user might recognize...
-mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
-
-mkSysLocal str uniq ty loc
- = Id uniq (mkLocalName uniq str True{-emph uniq-} loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
-
-mkUserLocal str uniq ty loc
- = Id uniq (mkLocalName uniq str False{-emph name-} loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
+omitIfaceSigForId :: Id -> Bool
+omitIfaceSigForId id
+ | isWiredInName (idName id)
+ = True
--- mkUserId builds a local or top-level Id, depending on the name given
-mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
-mkUserId name ty pragma_info
- | isLocalName name
- = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo
| otherwise
- = Id (nameUnique name) name ty
- (if isLocallyDefinedName name then TopLevId else ImportedId)
- pragma_info noIdInfo
-\end{code}
-
+ = case varDetails id of
+ RecordSelId _ -> True -- Includes dictionary selectors
+ ConstantId _ -> True
+ -- ConstantIds are implied by their type or class decl;
+ -- remember that all type and class decls appear in the interface file.
+ -- The dfun id must *not* be omitted, because it carries version info for
+ -- the instance decl
-\begin{code}
-{-LATER:
-
--- for a SpecPragmaId being created by the compiler out of thin air...
-mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
-mkSpecPragmaId str uniq ty specid loc
- = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty))
-
--- for new SpecId
-mkSpecId u unspec ty_maybes ty info
- = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
- Id u n ty info (SpecId unspec ty_maybes (no_free_tvs ty))
-
--- Specialised version of constructor: only used in STG and code generation
--- Note: The specialsied Id has the same unique as the unspeced Id
-
-mkSameSpecCon ty_maybes unspec@(Id u n ty info details)
- = ASSERT(isDataCon unspec)
- ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
- Id u n new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
- where
- new_ty = specialiseTy ty ty_maybes 0
-
-localiseId :: Id -> Id
-localiseId id@(Id u n ty info details)
- = Id u (mkShortName name loc) ty info (LocalId (no_free_tvs ty))
- where
- name = getOccName id
- loc = getSrcLoc id
--}
-
-mkIdWithNewUniq :: Id -> Unique -> Id
-
-mkIdWithNewUniq (Id _ n ty details prag info) u
- = Id u (changeUnique n u) ty details prag info
+ other -> False -- Don't omit!
\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}
-mkTemplateLocals :: [Type] -> [Id]
-mkTemplateLocals tys
- = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
- (getBuiltinUniques (length tys))
- tys
-\end{code}
-
-\begin{code}
-getIdInfo :: GenId ty -> IdInfo
-getPragmaInfo :: GenId ty -> PragmaInfo
-
-getIdInfo (Id _ _ _ _ _ info) = info
-getPragmaInfo (Id _ _ _ _ info _) = info
-
-{-LATER:
-replaceIdInfo :: Id -> IdInfo -> Id
-
-replaceIdInfo (Id u n ty _ details) info = Id u n ty info details
-
-selectIdInfoForSpecId :: Id -> IdInfo
-selectIdInfoForSpecId unspec
- = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
- noIdInfo `addInfo_UF` getIdUnfolding unspec
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Id-arities]{Arity-related functions}
-%* *
-%************************************************************************
-
-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!)
+See notes with setNameVisibility (Name.lhs)
\begin{code}
-getIdArity :: Id -> ArityInfo
-getIdArity (Id _ _ _ _ _ id_info) = getInfo id_info
+setIdVisibility :: Maybe Module -> Unique -> Id -> Id
+setIdVisibility maybe_mod u id
+ = setIdName id (setNameVisibility maybe_mod u (idName id))
-dataConArity :: DataCon -> Int
-dataConArity id@(Id _ _ _ _ _ id_info)
- = ASSERT(isDataCon id)
- case (arityMaybe (getInfo id_info)) of
- Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
- Just i -> i
-
-isNullaryDataCon con = dataConArity con == 0 -- function of convenience
-
-addIdArity :: Id -> Int -> Id
-addIdArity (Id u n ty details pinfo info) arity
- = Id u n ty details pinfo (info `addInfo` (mkArityInfo arity))
+mkIdVisible :: Module -> Unique -> Id -> Id
+mkIdVisible mod u id
+ = setIdName id (mkNameVisible mod u (idName id))
\end{code}
%************************************************************************
%* *
-\subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
+\subsection{Special Ids}
%* *
%************************************************************************
\begin{code}
-mkDataCon :: Name
- -> [StrictnessMark] -> [FieldLabel]
- -> [TyVar] -> ThetaType -> [TauType] -> TyCon
---ToDo: -> SpecEnv
- -> Id
- -- can get the tag and all the pieces of the type from the Type
-
-mkDataCon n stricts fields tvs ctxt args_tys tycon
- = ASSERT(length stricts == length args_tys)
- data_con
- where
- -- NB: data_con self-recursion; should be OK as tags are not
- -- looked at until late in the game.
- data_con
- = Id (nameUnique n)
- n
- type_of_constructor
- (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
- NoPragmaInfo
- datacon_info
-
- data_con_tag = position_within fIRST_TAG data_con_family
-
- data_con_family = tyConDataCons tycon
-
- position_within :: Int -> [Id] -> Int
-
- position_within acc (c:cs)
- = if c == data_con then acc else position_within (acc+1) cs
-#ifdef DEBUG
- position_within acc []
- = panic "mkDataCon: con not found in family"
-#endif
-
- type_of_constructor
- = mkSigmaTy tvs ctxt
- (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
-
- datacon_info = noIdInfo `addInfo_UF` unfolding
- `addInfo` mkArityInfo arity
---ToDo: `addInfo` specenv
-
- arity = length args_tys
-
- unfolding
- = noInfo_UF
-{- LATER:
- = -- if arity == 0
- -- then noIdInfo
- -- else -- do some business...
- let
- (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
- tyvar_tys = mkTyVarTys tyvars
- in
- case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
-
- mkUnfolding EssentialUnfolding -- for data constructors
- (mkLam tyvars (dict_vars ++ vars) plain_Con)
- }
-
- mk_uf_bits tvs ctxt arg_tys tycon
- = let
- (inst_env, tyvars, tyvar_tys)
- = instantiateTyVarTemplates tvs
- (map uniqueOf tvs)
- in
- -- the "context" and "arg_tys" have TyVarTemplates in them, so
- -- we instantiate those types to have the right TyVars in them
- -- instead.
- case (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
- of { inst_dict_tys ->
- case (map (instantiateTauTy inst_env) arg_tys) of { inst_arg_tys ->
-
- -- We can only have **ONE** call to mkTemplateLocals here;
- -- otherwise, we get two blobs of locals w/ mixed-up Uniques
- -- (Mega-Sigh) [ToDo]
- case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars ->
-
- case (splitAt (length ctxt) all_vars) of { (dict_vars, vars) ->
-
- (tyvars, dict_vars, vars)
- }}}}
- where
- -- these are really dubious Types, but they are only to make the
- -- binders for the lambdas for tossed-away dicts.
- ctxt_ty (clas, ty) = mkDictTy clas ty
--}
-\end{code}
-
-\begin{code}
-mkTupleCon :: Arity -> Id
-
-mkTupleCon arity
- = Id unique n ty (TupleConId arity) NoPragmaInfo tuplecon_info
- where
- n = mkTupleDataConName arity
- unique = uniqueOf n
- ty = mkSigmaTy tyvars []
- (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
- tycon = mkTupleTyCon arity
- tyvars = take arity alphaTyVars
- tyvar_tys = mkTyVarTys tyvars
-
- tuplecon_info
- = noIdInfo `addInfo_UF` unfolding
- `addInfo` mkArityInfo arity
---LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
-
- unfolding
- = noInfo_UF
-{- LATER:
- = -- if arity == 0
- -- then noIdInfo
- -- else -- do some business...
- let
- (tyvars, dict_vars, vars) = mk_uf_bits arity
- tyvar_tys = mkTyVarTys tyvars
- in
- case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
- mkUnfolding
- EssentialUnfolding -- data constructors
- (mkLam tyvars (dict_vars ++ vars) plain_Con) }
-
- mk_uf_bits arity
- = case (mkTemplateLocals tyvar_tys) of { vars ->
- (tyvars, [], vars) }
- where
- tyvar_tmpls = take arity alphaTyVars
- (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
--}
-
-fIRST_TAG :: ConTag
-fIRST_TAG = 1 -- Tags allocated from here for real constructors
-\end{code}
-
-\begin{code}
-dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
-dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _) _ _) = tag
-dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG
-dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
-
-dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
-dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
-dataConTyCon (Id _ _ _ (TupleConId a) _ _) = mkTupleTyCon a
-
-dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
- -- will panic if not a DataCon
-
-dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
- = (tyvars, theta_ty, arg_tys, tycon)
-
-dataConSig (Id _ _ _ (TupleConId arity) _ _)
- = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
- where
- tyvars = take arity alphaTyVars
- tyvar_tys = mkTyVarTys tyvars
-
-dataConFieldLabels :: DataCon -> [FieldLabel]
-dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields
-dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = []
-
-dataConStrictMarks :: DataCon -> [StrictnessMark]
-dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts
-dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _)
- = nOfThem arity NotMarkedStrict
-
-dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
-dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
-
-dataConArgTys :: DataCon
- -> [Type] -- Instantiated at these types
- -> [Type] -- Needs arguments of these types
-dataConArgTys con_id inst_tys
- = map (instantiateTy tenv) arg_tys
- where
- (tyvars, _, arg_tys, _) = dataConSig con_id
- tenv = zipEqual "dataConArgTys" tyvars inst_tys
-\end{code}
-
-\begin{code}
-mkRecordSelId field_label selector_ty
- = Id (nameUnique name)
- name
- selector_ty
- (RecordSelId field_label)
- NoPragmaInfo
- noIdInfo
- where
- name = fieldLabelName field_label
-
recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl
-\end{code}
+recordSelectorFieldLabel id = case varDetails id of
+ RecordSelId lbl -> lbl
+isRecordSelector id = case varDetails id of
+ RecordSelId lbl -> True
+ other -> False
-Data type declarations are of the form:
-\begin{verbatim}
-data Foo a b = C1 ... | C2 ... | ... | Cn ...
-\end{verbatim}
-For each constructor @Ci@, we want to generate a curried function; so, e.g., for
-@C1 x y z@, we want a function binding:
-\begin{verbatim}
-fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
-\end{verbatim}
-Notice the ``big lambdas'' and type arguments to @Con@---we are producing
-2nd-order polymorphic lambda calculus with explicit types.
+isPrimitiveId_maybe id = case varDetails id of
+ ConstantId (PrimOp op) -> Just op
+ other -> Nothing
-%************************************************************************
-%* *
-\subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
-%* *
-%************************************************************************
+isDataConId_maybe id = case varDetails id of
+ ConstantId (DataCon con) -> Just con
+ other -> Nothing
-@getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
-and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
-@TyVars@ don't really have to be new, because we are only producing a
-template.
-
-ToDo: what if @DataConId@'s type has a context (haven't thought about it
---WDP)?
-
-Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
-EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the
-example above: a, b, and x, y, z], which is enough (in the important
-\tr{DsExpr} case). (The middle set of @Ids@ is binders for any
-dictionaries, in the even of an overloaded data-constructor---none at
-present.)
-
-\begin{code}
-getIdUnfolding :: Id -> UnfoldingDetails
-
-getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
-
-{-LATER:
-addIdUnfolding :: Id -> UnfoldingDetails -> Id
-addIdUnfolding id@(Id u n ty info details) unfold_details
- = ASSERT(
- case (isLocallyDefined id, unfold_details) of
- (_, NoUnfoldingDetails) -> True
- (True, IWantToBeINLINEd _) -> True
- (False, IWantToBeINLINEd _) -> False -- v bad
- (False, _) -> True
- _ -> False -- v bad
- )
- Id u n ty (info `addInfo_UF` unfold_details) details
--}
+isConstantId id = case varDetails id of
+ ConstantId _ -> True
+ other -> False
\end{code}
-In generating selector functions (take a dictionary, give back one
-component...), we need to what out for the nothing-to-select cases (in
-which case the ``selector'' is just an identity function):
-\begin{verbatim}
-class Eq a => Foo a { } # the superdict selector for "Eq"
-
-class Foo a { op :: Complex b => c -> b -> a }
- # the method selector for "op";
- # note local polymorphism...
-\end{verbatim}
%************************************************************************
%* *
-\subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
+\subsection{IdInfo stuff}
%* *
%************************************************************************
\begin{code}
-getIdDemandInfo :: Id -> DemandInfo
-getIdDemandInfo (Id _ _ _ _ _ info) = getInfo info
+ ---------------------------------
+ -- ARITY
+getIdArity :: GenId flexi -> ArityInfo
+getIdArity id = arityInfo (idInfo id)
-addIdDemandInfo :: Id -> DemandInfo -> Id
-addIdDemandInfo (Id u n ty details prags info) demand_info
- = Id u n ty details prags (info `addInfo` demand_info)
-\end{code}
+setIdArity :: GenId flexi -> ArityInfo -> GenId flexi
+setIdArity id arity = modifyIdInfo id (arity `setArityInfo`)
-\begin{code}
-getIdUpdateInfo :: Id -> UpdateInfo
-getIdUpdateInfo (Id _ _ _ _ _ info) = getInfo info
+ ---------------------------------
+ -- STRICTNESS
+getIdStrictness :: GenId flexi -> StrictnessInfo
+getIdStrictness id = strictnessInfo (idInfo id)
-addIdUpdateInfo :: Id -> UpdateInfo -> Id
-addIdUpdateInfo (Id u n ty details prags info) upd_info
- = Id u n ty details prags (info `addInfo` upd_info)
-\end{code}
+setIdStrictness :: GenId flexi -> StrictnessInfo -> GenId flexi
+setIdStrictness id strict_info = modifyIdInfo id (strict_info `setStrictnessInfo`)
-\begin{code}
-{- LATER:
-getIdArgUsageInfo :: Id -> ArgUsageInfo
-getIdArgUsageInfo (Id u n ty info details) = getInfo info
-
-addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
-addIdArgUsageInfo (Id u n ty info details) au_info
- = Id u n ty (info `addInfo` au_info) details
--}
-\end{code}
+isBottomingId :: GenId flexi -> Bool
+isBottomingId id = bottomIsGuaranteed (strictnessInfo (idInfo id))
-\begin{code}
-{- LATER:
-getIdFBTypeInfo :: Id -> FBTypeInfo
-getIdFBTypeInfo (Id u n ty info details) = getInfo info
-
-addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
-addIdFBTypeInfo (Id u n ty info details) upd_info
- = Id u n ty (info `addInfo` upd_info) details
--}
-\end{code}
+ ---------------------------------
+ -- UNFOLDING
+getIdUnfolding :: GenId flexi -> Unfolding
+getIdUnfolding id = unfoldingInfo (idInfo id)
-\begin{code}
-{- LATER:
-getIdSpecialisation :: Id -> SpecEnv
-getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
-
-addIdSpecialisation :: Id -> SpecEnv -> Id
-addIdSpecialisation (Id u n ty details prags info) spec_info
- = Id u n ty details prags (info `addInfo` spec_info)
--}
-\end{code}
+setIdUnfolding :: GenId flexi -> Unfolding -> GenId flexi
+setIdUnfolding id unfolding = modifyIdInfo id (unfolding `setUnfoldingInfo`)
-Strictness: we snaffle the info out of the IdInfo.
+ ---------------------------------
+ -- DEMAND
+getIdDemandInfo :: GenId flexi -> Demand
+getIdDemandInfo id = demandInfo (idInfo id)
-\begin{code}
-getIdStrictness :: Id -> StrictnessInfo
+setIdDemandInfo :: GenId flexi -> Demand -> GenId flexi
+setIdDemandInfo id demand_info = modifyIdInfo id (demand_info `setDemandInfo`)
-getIdStrictness (Id _ _ _ _ _ info) = getInfo info
+ ---------------------------------
+ -- UPDATE INFO
+getIdUpdateInfo :: GenId flexi -> UpdateInfo
+getIdUpdateInfo id = updateInfo (idInfo id)
-addIdStrictness :: Id -> StrictnessInfo -> Id
+setIdUpdateInfo :: GenId flexi -> UpdateInfo -> GenId flexi
+setIdUpdateInfo id upd_info = modifyIdInfo id (upd_info `setUpdateInfo`)
-addIdStrictness (Id u n ty details prags info) strict_info
- = Id u n ty details prags (info `addInfo` strict_info)
-\end{code}
+ ---------------------------------
+ -- SPECIALISATION
+getIdSpecialisation :: GenId flexi -> IdSpecEnv
+getIdSpecialisation id = specInfo (idInfo id)
-%************************************************************************
-%* *
-\subsection[Id-comparison]{Comparison functions for @Id@s}
-%* *
-%************************************************************************
+setIdSpecialisation :: GenId flexi -> IdSpecEnv -> GenId flexi
+setIdSpecialisation id spec_info = modifyIdInfo id (spec_info `setSpecInfo`)
-Comparison: equality and ordering---this stuff gets {\em hammered}.
+ ---------------------------------
+ -- CAF INFO
+getIdCafInfo :: GenId flexi -> CafInfo
+getIdCafInfo id = cafInfo (idInfo id)
-\begin{code}
-cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = cmp u1 u2
--- short and very sweet
+setIdCafInfo :: GenId flexi -> CafInfo -> GenId flexi
+setIdCafInfo id caf_info = modifyIdInfo id (caf_info `setCafInfo`)
\end{code}
-\begin{code}
-instance Ord3 (GenId ty) where
- cmp = cmpId
-
-instance Eq (GenId ty) where
- a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
- a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
-
-instance Ord (GenId ty) where
- a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-\end{code}
-@cmpId_withSpecDataCon@ ensures that any spectys are taken into
-account when comparing two data constructors. We need to do this
-because a specialised data constructor has the same Unique as its
-unspecialised counterpart.
+ ---------------------------------
+ -- 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}
-cmpId_withSpecDataCon :: Id -> Id -> TAG_
+getInlinePragma :: GenId flexi -> InlinePragInfo
+getInlinePragma id = inlinePragInfo (idInfo id)
-cmpId_withSpecDataCon id1 id2
- | eq_ids && isDataCon id1 && isDataCon id2
- = cmpEqDataCon id1 id2
+setInlinePragma :: GenId flexi -> InlinePragInfo -> GenId flexi
+setInlinePragma id prag = modifyIdInfo id (setInlinePragInfo prag)
- | otherwise
- = cmp_ids
- where
- cmp_ids = cmpId id1 id2
- eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
+modifyInlinePragma :: GenId flexi -> (InlinePragInfo -> InlinePragInfo) -> GenId flexi
+modifyInlinePragma id fn = modifyIdInfo id (\info -> setInlinePragInfo (fn (inlinePragInfo info)) info)
-cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _)
- = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
+idWantsToBeINLINEd :: GenId flexi -> Bool
+idWantsToBeINLINEd id = case getInlinePragma id of
+ IWantToBeINLINEd -> True
+ IMustBeINLINEd -> True
+ other -> False
-cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_
-cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_
-cmpEqDataCon _ _ = EQ_
-\end{code}
+idMustNotBeINLINEd id = case getInlinePragma id of
+ IMustNotBeINLINEd -> True
+ IAmASpecPragmaId -> True
+ IAmALoopBreaker -> True
+ other -> False
-%************************************************************************
-%* *
-\subsection[Id-other-instances]{Other instance declarations for @Id@s}
-%* *
-%************************************************************************
-
-\begin{code}
-instance Outputable ty => Outputable (GenId ty) where
- ppr sty id = pprId sty id
-
--- and a SPECIALIZEd one:
-instance Outputable {-Id, i.e.:-}(GenId Type) where
- ppr sty id = pprId sty id
+idMustBeINLINEd id = case getInlinePragma id of
+ IMustBeINLINEd -> True
+ other -> False
-showId :: PprStyle -> Id -> String
-showId sty id = ppShow 80 (pprId sty id)
-\end{code}
-
-Default printing code (not used for interfaces):
-\begin{code}
-pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
-
-pprId sty (Id u n _ _ _ _) = ppr sty n
- -- WDP 96/05/06: We can re-elaborate this as we go along...
-\end{code}
-
-\begin{code}
-idUnique (Id u _ _ _ _ _) = u
-
-instance Uniquable (GenId ty) where
- uniqueOf = idUnique
-
-instance NamedThing (GenId ty) where
- getName this_id@(Id u n _ details _ _) = n
-\end{code}
-
-Note: The code generator doesn't carry a @UniqueSupply@, so it uses
-the @Uniques@ out of local @Ids@ given to it.
-
-%************************************************************************
-%* *
-\subsection{@IdEnv@s and @IdSet@s}
-%* *
-%************************************************************************
-
-\begin{code}
-type IdEnv elt = UniqFM elt
-
-nullIdEnv :: IdEnv a
-
-mkIdEnv :: [(GenId ty, a)] -> IdEnv a
-unitIdEnv :: GenId ty -> a -> IdEnv a
-addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
-growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
-growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
-
-delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
-delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
-combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
-mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
-modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
-rngIdEnv :: IdEnv a -> [a]
-
-isNullIdEnv :: IdEnv a -> Bool
-lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
-lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
-\end{code}
-
-\begin{code}
-addOneToIdEnv = addToUFM
-combineIdEnvs = plusUFM_C
-delManyFromIdEnv = delListFromUFM
-delOneFromIdEnv = delFromUFM
-growIdEnv = plusUFM
-lookupIdEnv = lookupUFM
-mapIdEnv = mapUFM
-mkIdEnv = listToUFM
-nullIdEnv = emptyUFM
-rngIdEnv = eltsUFM
-unitIdEnv = unitUFM
-
-growIdEnvList env pairs = plusUFM env (listToUFM pairs)
-isNullIdEnv env = sizeUFM env == 0
-lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
-
--- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
--- modify function, and put it back.
-
-modifyIdEnv env mangle_fn key
- = case (lookupIdEnv env key) of
- Nothing -> env
- Just xx -> addOneToIdEnv env key (mangle_fn xx)
-\end{code}
-
-\begin{code}
-type GenIdSet ty = UniqSet (GenId ty)
-type IdSet = UniqSet (GenId Type)
-
-emptyIdSet :: GenIdSet ty
-intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
-unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
-unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
-idSetToList :: GenIdSet ty -> [GenId ty]
-unitIdSet :: GenId ty -> GenIdSet ty
-addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
-elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
-minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
-isEmptyIdSet :: GenIdSet ty -> Bool
-mkIdSet :: [GenId ty] -> GenIdSet ty
-
-emptyIdSet = emptyUniqSet
-unitIdSet = unitUniqSet
-addOneToIdSet = addOneToUniqSet
-intersectIdSets = intersectUniqSets
-unionIdSets = unionUniqSets
-unionManyIdSets = unionManyUniqSets
-idSetToList = uniqSetToList
-elementOfIdSet = elementOfUniqSet
-minusIdSet = minusUniqSet
-isEmptyIdSet = isEmptyUniqSet
-mkIdSet = mkUniqSet
-\end{code}
-
-\begin{code}
-addId, nmbrId :: Id -> NmbrM Id
-
-addId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
- = case (lookupUFM_Directly idenv u) of
- Just xx -> _trace "addId: already in map!" $
- (nenv, xx)
- Nothing ->
- if toplevelishId id then
- _trace "addId: can't add toplevelish!" $
- (nenv, id)
- else -- alloc a new unique for this guy
- -- and add an entry in the idenv
- -- NB: *** KNOT-TYING ***
- let
- nenv_plus_id = NmbrEnv (incrUnique ui) ut uu
- (addToUFM_Directly idenv u new_id)
- tvenv uvenv
-
- (nenv2, new_ty) = nmbrType ty nenv_plus_id
- (nenv3, new_det) = nmbr_details det nenv2
-
- new_id = Id ui n new_ty new_det prag info
- in
- (nenv3, new_id)
-
-nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
- = case (lookupUFM_Directly idenv u) of
- Just xx -> (nenv, xx)
- Nothing ->
- if not (toplevelishId id) then
- _trace "nmbrId: lookup failed" $
- (nenv, id)
- else
- let
- (nenv2, new_ty) = nmbrType ty nenv
- (nenv3, new_det) = nmbr_details det nenv2
-
- new_id = Id u n new_ty new_det prag info
- in
- (nenv3, new_id)
-
-------------
-nmbr_details :: IdDetails -> NmbrM IdDetails
-
-nmbr_details (DataConId tag marks fields tvs theta arg_tys tc)
- = mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs ->
- mapNmbr nmbrField fields `thenNmbr` \ new_fields ->
- mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
- mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys ->
- returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_arg_tys tc)
- where
- nmbr_theta (c,t)
- = --nmbrClass c `thenNmbr` \ new_c ->
- nmbrType t `thenNmbr` \ new_t ->
- returnNmbr (c, new_t)
-
- -- ToDo:add more cases as needed
-nmbr_details other_details = returnNmbr other_details
-
-------------
-nmbrField (FieldLabel n ty tag)
- = nmbrType ty `thenNmbr` \ new_ty ->
- returnNmbr (FieldLabel n new_ty tag)
+isSpecPragmaId id = case getInlinePragma id of
+ IAmASpecPragmaId -> True
+ other -> False
\end{code}
projects / ghc-hetmet.git / blobdiff