-%
+
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Id]{@Ids@: Value and constructor identifiers}
\begin{code}
-#include "HsVersions.h"
-
module Id (
-- TYPES
GenId(..), -- *naughtily* used in some places (e.g., TcHsSyn)
- SYN_IE(Id), IdDetails,
+ Id, IdDetails,
StrictnessMark(..),
- SYN_IE(ConTag), fIRST_TAG,
- SYN_IE(DataCon), SYN_IE(DictFun), SYN_IE(DictVar),
+ ConTag, fIRST_TAG,
+ DataCon, DictFun, DictVar,
-- CONSTRUCTION
- mkConstMethodId,
mkDataCon,
mkDefaultMethodId,
mkDictFunId,
- mkIdWithNewUniq, mkIdWithNewName,
+ mkIdWithNewUniq, mkIdWithNewName, mkIdWithNewType,
mkImported,
- mkInstId,
mkMethodSelId,
mkRecordSelId,
mkSuperDictSelId,
mkTupleCon,
mkUserId,
mkUserLocal,
- mkWorkerId,
mkPrimitiveId,
+ mkWorkerId,
setIdVisibility,
-- DESTRUCTION (excluding pragmatic info)
idPrimRep,
idType,
idUnique,
+ idName,
dataConRepType,
dataConArgTys,
-- PREDICATES
omitIfaceSigForId,
- cmpEqDataCon,
cmpId,
- cmpId_withSpecDataCon,
externallyVisibleId,
idHasNoFreeTyVars,
idWantsToBeINLINEd, getInlinePragma,
idMustBeINLINEd, idMustNotBeINLINEd,
isBottomingId,
- isConstMethodId,
- isConstMethodId_maybe,
isDataCon, isAlgCon, isNewCon,
isDefaultMethodId,
isDefaultMethodId_maybe,
isDictFunId,
isImportedId,
isRecordSelector,
- isMethodSelId_maybe,
+ isDictSelId_maybe,
isNullaryDataCon,
- isSpecPragmaId,
- isSuperDictSelId_maybe,
isPrimitiveId_maybe,
isSysLocalId,
isTupleCon,
- isWorkerId,
isWrapperId,
toplevelishId,
unfoldingUnfriendlyId,
- -- SUBSTITUTION
- applyTypeEnvToId,
- apply_to_Id,
-
-- PRINTING and RENUMBERING
- addId,
- nmbrDataCon,
- nmbrId,
pprId,
showId,
-- Specialialisation
getIdSpecialisation,
- addIdSpecialisation,
+ setIdSpecialisation,
-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
addIdUnfolding,
addIdDemandInfo,
addIdStrictness,
addIdUpdateInfo,
- addIdDeforestInfo,
getIdArity,
getIdDemandInfo,
getIdInfo,
addInlinePragma, nukeNoInlinePragma, addNoInlinePragma,
-- IdEnvs AND IdSets
- SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
+ IdEnv, GenIdSet, IdSet,
addOneToIdEnv,
addOneToIdSet,
combineIdEnvs,
intersectIdSets,
isEmptyIdSet,
isNullIdEnv,
- lookupIdEnv,
+ lookupIdEnv, lookupIdSubst,
lookupNoFailIdEnv,
mapIdEnv,
minusIdSet,
- mkIdEnv,
+ mkIdEnv, elemIdEnv,
mkIdSet,
modifyIdEnv,
modifyIdEnv_Directly,
unitIdSet
) where
-IMP_Ubiq()
+#include "HsVersions.h"
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(IdLoop) -- for paranoia checking
-IMPORT_DELOOPER(TyLoop) -- for paranoia checking
-#else
-import {-# SOURCE #-} SpecEnv ( SpecEnv )
import {-# SOURCE #-} CoreUnfold ( Unfolding )
import {-# SOURCE #-} StdIdInfo ( addStandardIdInfo )
--- Let's see how much we can leave out..
---import {-# SOURCE #-} TyCon
---import {-# SOURCE #-} Type
---import {-# SOURCE #-} Class
---import {-# SOURCE #-} TysWiredIn
---import {-# SOURCE #-} TysPrim
---import {-# SOURCE #-} TyVar
-#endif
+import CmdLineOpts ( opt_PprStyle_All )
+import SpecEnv ( SpecEnv )
import Bag
-import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp )
+import Class ( Class )
+import BasicTypes ( Arity )
import IdInfo
import Maybes ( maybeToBool )
import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName,
- mkCompoundName, mkInstDeclName,
- isLocallyDefinedName, occNameString, modAndOcc,
- isLocallyDefined, changeUnique, isWiredInName,
- nameString, getOccString, setNameVisibility,
- isExported, ExportFlag(..), DefnInfo, Provenance,
- OccName(..), Name, SYN_IE(Module),
+ mkCompoundName, occNameString, modAndOcc,
+ changeUnique, isWiredInName, setNameVisibility,
+ ExportFlag(..), Provenance,
+ OccName(..), Name, Module,
NamedThing(..)
)
+import PrimOp ( PrimOp )
import PrelMods ( pREL_TUP, pREL_BASE )
-import Lex ( mkTupNameStr )
import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
import PragmaInfo ( PragmaInfo(..) )
-#if __GLASGOW_HASKELL__ >= 202
-import PrimOp ( PrimOp )
-#endif
-import PprEnv -- ( SYN_IE(NmbrM), NmbrEnv(..) )
-import PprType ( getTypeString, specMaybeTysSuffix,
- nmbrType, nmbrTyVar,
- GenType, GenTyVar
- )
-import Pretty
-import MatchEnv ( MatchEnv )
-import SrcLoc --( mkBuiltinSrcLoc )
+import SrcLoc ( mkBuiltinSrcLoc )
import TysWiredIn ( tupleTyCon )
-import TyCon --( TyCon, tyConDataCons )
-import Type {- ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
- applyTyCon, instantiateTy, mkForAllTys,
- tyVarsOfType, applyTypeEnvToTy, typePrimRep,
- GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type)
- ) -}
-import TyVar --( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) )
-import Usage ( SYN_IE(UVar) )
+import TyCon ( TyCon, tyConDataCons, isDataTyCon, isNewTyCon, mkSpecTyCon )
+import Type ( mkSigmaTy, mkTyVarTys, mkFunTys,
+ mkTyConApp, instantiateTy, mkForAllTys,
+ tyVarsOfType, instantiateTy, typePrimRep,
+ instantiateTauTy,
+ GenType, ThetaType, TauType, Type
+ )
+import TyVar ( TyVar, alphaTyVars, isEmptyTyVarSet,
+ TyVarEnv, zipTyVarEnv, mkTyVarEnv
+ )
import UniqFM
import UniqSet -- practically all of it
-import Unique ( getBuiltinUniques, pprUnique, showUnique,
- incrUnique,
- Unique{-instance Ord3-}
- )
-import Outputable ( ifPprDebug, Outputable(..), PprStyle(..) )
-import Util {- ( mapAccumL, nOfThem, zipEqual, assoc,
- panic, panic#, pprPanic, assertPanic
- ) -}
+import Unique ( getBuiltinUniques, Unique, Uniquable(..) )
+import Outputable
+import SrcLoc ( SrcLoc )
+import Util ( nOfThem, assoc )
+import GlaExts ( Int# )
\end{code}
Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
-- as for LocalId
| PrimitiveId PrimOp -- The Id for a primitive operation
-
- | SpecPragmaId -- Local name; introduced by the compiler
- (Maybe Id) -- for explicit specid in pragma
- Bool -- as for LocalId
+
---------------- Global values
[FieldLabel] -- Field labels for this constructor;
--length = 0 (not a record) or arity
- [TyVar] [(Class,Type)] -- Type vars and context for the data type decl
- [TyVar] [(Class,Type)] -- Ditto for the context of the constructor,
+ [TyVar] ThetaType -- Type vars and context for the data type decl
+ [TyVar] ThetaType -- Ditto for the context of the constructor,
-- the existentially quantified stuff
[Type] TyCon -- Args and result tycon
-- the type is:
---------------- 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.
+ | DictSelId -- Selector that extracts a method or superclass from a dictionary
+ Class -- The class
| 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,
+ [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.
- -- 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).
-
--- Scheduled for deletion: SLPJ Nov 96
--- Nobody seems to depend on knowing this.
- | WorkerId -- A "worker" for some other Id
- Id -- Id for which this is a worker
type ConTag = Int
type DictVar = Id
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}
(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:
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
+Note that @Locals@ and @SysLocals@ {\em may} have the above
properties, but they may not.
\end{enumerate}
-- isDataCon returns False for @newtype@ constructors
isDataCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tc) _ _) = isDataTyCon tc
isDataCon (Id _ _ _ (TupleConId _) _ _) = True
-isDataCon (Id _ _ _ (SpecId unspec _ _) _ _) = isDataCon unspec
isDataCon other = False
isNewCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tc) _ _) = isNewTyCon tc
-- isAlgCon returns True for @data@ or @newtype@ constructors
isAlgCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ _) _ _) = True
isAlgCon (Id _ _ _ (TupleConId _) _ _) = True
-isAlgCon (Id _ _ _ (SpecId unspec _ _) _ _) = isAlgCon unspec
isAlgCon other = False
isTupleCon (Id _ _ _ (TupleConId _) _ _) = True
-isTupleCon (Id _ _ _ (SpecId unspec _ _) _ _) = isTupleCon unspec
isTupleCon other = False
\end{code}
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
- chk (SuperDictSelId _ _) = True
- chk (MethodSelId _ _) = True
- chk (DefaultMethodId _ _ _) = True
+ chk (DictSelId _) = 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
chk (PrimitiveId _) = True
idHasNoFreeTyVars (Id _ _ _ details _ info)
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
- chk (SuperDictSelId _ _) = True
- chk (MethodSelId _ _) = True
- chk (DefaultMethodId _ _ _) = True
+ chk (DictSelId _) = 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
chk (PrimitiveId _) = True
-- omitIfaceSigForId tells whether an Id's info is implied by other declarations,
-- The dfun id must *not* be omitted, because it carries version info for
-- the instance decl
(AlgConId _ _ _ _ _ _ _ _ _) -> True
- (TupleConId _) -> True
- (RecordSelId _) -> True
- (SuperDictSelId _ _) -> True
- (MethodSelId _ _) -> True
+ (TupleConId _) -> True
+ (RecordSelId _) -> True
+ (DictSelId _) -> True
- other -> False -- Don't omit!
+ other -> False -- Don't omit!
-- NB DefaultMethodIds are not omitted
\end{code}
isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True
isSysLocalId other = False
-isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True
-isSpecPragmaId other = False
-
-isMethodSelId_maybe (Id _ _ _ (MethodSelId cls op) _ _) = Just (cls,op)
-isMethodSelId_maybe _ = Nothing
+isDictSelId_maybe (Id _ _ _ (DictSelId cls) _ _) = Just cls
+isDictSelId_maybe _ = Nothing
-isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
-isDefaultMethodId other = False
+isDefaultMethodId (Id _ _ _ (DefaultMethodId _) _ _) = True
+isDefaultMethodId other = False
-isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _)
- = Just (cls, clsop, err)
+isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls) _ _)
+ = Just cls
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
-
isWrapperId id = workerExists (getIdStrictness id)
isPrimitiveId_maybe (Id _ _ _ (PrimitiveId primop) _ _) = Just primop
isPrimitiveId_maybe other = Nothing
\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
-- not local => global => externally visible
\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.
-
-\begin{code}
-type TypeEnv = TyVarEnv Type
-
-applyTypeEnvToId :: TypeEnv -> Id -> Id
-
-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
-\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}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-idType :: GenId ty -> ty
+idName :: GenId ty -> Name
+idName (Id _ n _ _ _ _) = n
+idType :: GenId ty -> ty
idType (Id _ _ ty _ _ _) = ty
-\end{code}
-\begin{code}
-{-LATER:
-getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
-
-getMentionedTyConsAndClassesFromId id
- = getMentionedTyConsAndClassesFromType (idType id)
--}
-\end{code}
-
-\begin{code}
idPrimRep i = typePrimRep (idType i)
\end{code}
%************************************************************************
\begin{code}
-mkSuperDictSelId u clas sc ty
+mkSuperDictSelId :: Unique -> Class -> Int -> Type -> Id
+ -- The Int is an arbitrary tag to say which superclass is selected
+ -- So, for
+ -- class (C a, C b) => Foo a b where ...
+ -- we get superclass selectors
+ -- Foo_sc1, Foo_sc2
+
+mkSuperDictSelId u clas index ty
= addStandardIdInfo $
Id u name ty details NoPragmaInfo noIdInfo
where
name = mkCompoundName name_fn u (getName clas)
- details = SuperDictSelId clas sc
- name_fn clas_str = SLIT("scsel_") _APPEND_ clas_str _APPEND_ mod _APPEND_ occNameString occ
- (mod,occ) = modAndOcc sc
+ details = DictSelId clas
+ name_fn clas_str = clas_str _APPEND_ SLIT("_sc") _APPEND_ (_PK_ (show index))
-- For method selectors the clean thing to do is
-- to give the method selector the same name as the class op itself.
-mkMethodSelId op_name rec_c op ty
+mkMethodSelId op_name clas ty
= addStandardIdInfo $
- Id (uniqueOf op_name) op_name ty (MethodSelId rec_c op) NoPragmaInfo noIdInfo
+ Id (uniqueOf op_name) op_name ty (DictSelId clas) NoPragmaInfo noIdInfo
-mkDefaultMethodId dm_name rec_c op gen ty
- = Id (uniqueOf dm_name) dm_name ty (DefaultMethodId rec_c op gen) NoPragmaInfo noIdInfo
+mkDefaultMethodId dm_name rec_c ty
+ = Id (uniqueOf dm_name) dm_name ty (DefaultMethodId rec_c) NoPragmaInfo noIdInfo
-mkDictFunId dfun_name full_ty clas ity
+mkDictFunId dfun_name full_ty clas itys
= Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo
where
- details = DictFunId clas ity
-
-mkConstMethodId uniq clas op ity full_ty from_here locn mod info
- = Id uniq name full_ty details NoPragmaInfo info
- where
- name = mkInstDeclName uniq mod (VarOcc occ_name) locn from_here
- details = ConstMethodId clas ity op mod
- occ_name = classOpString op _APPEND_
- SLIT("_cm_") _APPEND_ renum_type_string full_ty ity
+ details = DictFunId clas itys
mkWorkerId u unwrkr ty info
= Id u name ty details NoPragmaInfo info
where
+ details = LocalId (no_free_tvs ty)
name = mkCompoundName name_fn u (getName unwrkr)
- details = WorkerId unwrkr
name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str
-
-mkInstId u ty name
- = Id u name 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:" (vcat [
- hsep [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
- ppr PprDebug sel_id],
- text "(This can arise if an interface pragma refers to an instance",
- text "but there is no imported interface which *defines* that instance.",
- text "The info above, however ugly, should indicate what else you need to import."
- ])
--}
-
-
-renum_type_string full_ty ity
- = initNmbr (
- nmbrType full_ty `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering...
- nmbrType ity `thenNmbr` \ rn_ity ->
- returnNmbr (getTypeString rn_ity)
- )
\end{code}
%************************************************************************
Id (nameUnique n) n ty (PrimitiveId primop) IMustBeINLINEd noIdInfo
-- The pragma @IMustBeINLINEd@ says that this Id absolutely must be inlined.
-- It's only true for primitives, because we don't want to make a closure for each of them.
+
\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 :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
-mkUserLocal :: OccName -> Unique -> MyTy a b -> SrcLoc -> MyId a b
+mkSysLocal :: FAST_STRING -> Unique -> GenType flexi -> SrcLoc -> GenId (GenType flexi)
+mkUserLocal :: OccName -> Unique -> GenType flexi -> SrcLoc -> GenId (GenType flexi)
mkSysLocal str uniq ty loc
= Id uniq (mkSysLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
mkUserLocal occ uniq ty loc
= Id uniq (mkLocalName uniq occ loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
-mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
-mkUserId name ty pragma_info
- = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo
+mkUserId :: Name -> GenType flexi -> GenId (GenType flexi)
+mkUserId name ty
+ = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
\end{code}
-
\begin{code}
-{-LATER:
-
--- for a SpecPragmaId being created by the compiler out of thin air...
-mkSpecPragmaId :: OccName -> 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
--}
-
-- See notes with setNameVisibility (Name.lhs)
-setIdVisibility :: Module -> Id -> Id
-setIdVisibility mod (Id uniq name ty details prag info)
- = Id uniq (setNameVisibility mod name) ty details prag info
+setIdVisibility :: Maybe Module -> Unique -> Id -> Id
+setIdVisibility maybe_mod u (Id uniq name ty details prag info)
+ = Id uniq (setNameVisibility maybe_mod u name) ty details prag info
mkIdWithNewUniq :: Id -> Unique -> Id
mkIdWithNewUniq (Id _ n ty details prag info) u
mkIdWithNewName :: Id -> Name -> Id
mkIdWithNewName (Id _ _ ty details prag info) new_name
= Id (uniqueOf new_name) new_name ty details prag info
+
+mkIdWithNewType :: Id -> Type -> Id
+mkIdWithNewType (Id u name _ details pragma info) ty
+ = Id u name ty details pragma info
\end{code}
Make some local @Ids@ for a template @CoreExpr@. These have bogus
%************************************************************************
%* *
-\subsection[Id-arities]{Deforestation related functions}
-%* *
-%************************************************************************
-
-\begin{code}
-addIdDeforestInfo :: Id -> DeforestInfo -> Id
-addIdDeforestInfo (Id u n ty details pinfo info) def_info
- = Id u n ty details pinfo (info `addDeforestInfo` def_info)
-\end{code}
-
-%************************************************************************
-%* *
\subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
%* *
%************************************************************************
data_con_ty
= mkSigmaTy (tvs++con_tvs) (ctxt++con_ctxt)
- (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
+ (mkFunTys args_tys (mkTyConApp tycon (mkTyVarTys tvs)))
mkTupleCon :: Arity -> Name -> Type -> Id
\begin{code}
dataConNumFields id
- = ASSERT(isDataCon id)
+ = ASSERT( if (isDataCon id) then True else
+ pprTrace "dataConNumFields" (ppr id) False )
case (dataConSig id) of { (_, _, _, con_theta, arg_tys, _) ->
length con_theta + length arg_tys }
isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
+
\end{code}
dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
dataConTag (Id _ _ _ (AlgConId tag _ _ _ _ _ _ _ _) _ _) = tag
dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG
-dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
dataConTyCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tycon) _ _) = tycon
-- dataConRepType returns the type of the representation of a contructor
-- This may differ from the type of the contructor Id itself 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
-- Trep :: Int# -> a -> T a
-- Actually, the unboxed part isn't implemented yet!
-dataConRepType :: GenId (GenType tv u) -> GenType tv u
-dataConRepType con
- = mkForAllTys tyvars tau
- where
- (tyvars, theta, tau) = splitSigmaTy (idType con)
+dataConRepType :: Id -> Type
+dataConRepType (Id _ _ _ (AlgConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon) _ _)
+ = mkForAllTys (tyvars++con_tyvars)
+ (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
+dataConRepType other_id
+ = ASSERT( isDataCon other_id )
+ idType other_id
dataConFieldLabels :: DataCon -> [FieldLabel]
dataConFieldLabels (Id _ _ _ (AlgConId _ _ fields _ _ _ _ _ _) _ _) = fields
dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = []
+#ifdef DEBUG
+dataConFieldLabels x@(Id _ _ _ idt _ _) =
+ panic ("dataConFieldLabel: " ++
+ (case idt of
+ LocalId _ -> "l"
+ SysLocalId _ -> "sl"
+ PrimitiveId _ -> "p"
+ ImportedId -> "i"
+ RecordSelId _ -> "r"
+ DictSelId _ -> "m"
+ DefaultMethodId _ -> "d"
+ DictFunId _ _ -> "di"))
+#endif
dataConStrictMarks :: DataCon -> [StrictnessMark]
dataConStrictMarks (Id _ _ _ (AlgConId _ stricts _ _ _ _ _ _ _) _ _) = stricts
= map (instantiateTy tenv) arg_tys
where
(tyvars, _, _, _, arg_tys, _) = dataConSig con_id
- tenv = zipEqual "dataConArgTys" tyvars inst_tys
+ tenv = zipTyVarEnv tyvars inst_tys
\end{code}
\begin{code}
\end{code}
\begin{code}
-getIdSpecialisation :: Id -> SpecEnv
+getIdSpecialisation :: Id -> IdSpecEnv
getIdSpecialisation (Id _ _ _ _ _ info) = specInfo info
-addIdSpecialisation :: Id -> SpecEnv -> Id
-addIdSpecialisation (Id u n ty details prags info) spec_info
- = Id u n ty details prags (info `addSpecInfo` spec_info)
+setIdSpecialisation :: Id -> IdSpecEnv -> Id
+setIdSpecialisation (Id u n ty details prags info) spec_info
+ = Id u n ty details prags (info `setSpecInfo` spec_info)
\end{code}
Strictness: we snaffle the info out of the IdInfo.
\begin{code}
-getIdStrictness :: Id -> StrictnessInfo Id
+getIdStrictness :: Id -> StrictnessInfo
getIdStrictness (Id _ _ _ _ _ info) = strictnessInfo info
-addIdStrictness :: Id -> StrictnessInfo Id -> Id
+addIdStrictness :: Id -> StrictnessInfo -> Id
addIdStrictness (Id u n ty details prags info) strict_info
= Id u n ty details prags (info `addStrictnessInfo` strict_info)
\end{code}
Comparison: equality and ordering---this stuff gets {\em hammered}.
\begin{code}
-cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = cmp u1 u2
+cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = compare u1 u2
-- short and very sweet
\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 }
+ a == b = case (a `compare` b) of { EQ -> True; _ -> False }
+ a /= b = case (a `compare` 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.
-
-\begin{code}
-cmpId_withSpecDataCon :: Id -> Id -> TAG_
-
-cmpId_withSpecDataCon id1 id2
- | eq_ids && isDataCon id1 && isDataCon id2
- = cmpEqDataCon id1 id2
-
- | otherwise
- = cmp_ids
- where
- cmp_ids = cmpId id1 id2
- eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
-
-cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _)
- = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
-
-cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_
-cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_
-cmpEqDataCon _ _ = EQ_
+ 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 = cmpId a b
\end{code}
%************************************************************************
\begin{code}
instance Outputable ty => Outputable (GenId ty) where
- ppr sty id = pprId sty id
+ ppr id = pprId id
--- and a SPECIALIZEd one:
-instance Outputable {-Id, i.e.:-}(GenId Type) where
- ppr sty id = pprId sty id
-
-showId :: PprStyle -> Id -> String
-showId sty id = show (pprId sty id)
+showId :: Id -> String
+showId id = showSDoc (pprId id)
\end{code}
Default printing code (not used for interfaces):
\begin{code}
-pprId :: Outputable ty => PprStyle -> GenId ty -> Doc
+pprId :: Outputable ty => GenId ty -> SDoc
-pprId sty (Id u n _ _ prags _)
- = hcat [ppr sty n, pp_prags]
+pprId (Id u n _ _ prags _)
+ = hcat [ppr n, pp_prags]
where
- pp_prags = ifPprDebug sty (case prags of
- IMustNotBeINLINEd -> text "{n}"
- IWantToBeINLINEd -> text "{i}"
- IMustBeINLINEd -> text "{I}"
- other -> empty)
+ pp_prags | opt_PprStyle_All = case prags of
+ IMustNotBeINLINEd -> text "{n}"
+ IWantToBeINLINEd -> text "{i}"
+ IMustBeINLINEd -> text "{I}"
+ other -> empty
+ | otherwise = empty
-- WDP 96/05/06: We can re-elaborate this as we go along...
\end{code}
isNullIdEnv :: IdEnv a -> Bool
lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
+elemIdEnv :: Id -> IdEnv a -> Bool
\end{code}
\begin{code}
+elemIdEnv = elemUFM
addOneToIdEnv = addToUFM
combineIdEnvs = plusUFM_C
delManyFromIdEnv = delListFromUFM
nullIdEnv = emptyUFM
rngIdEnv = eltsUFM
unitIdEnv = unitUFM
+isNullIdEnv = isNullUFM
growIdEnvList env pairs = plusUFM env (listToUFM pairs)
-isNullIdEnv env = sizeUFM env == 0
lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
+lookupIdSubst :: IdEnv Id -> Id -> Id
+lookupIdSubst env id = case lookupIdEnv env id of
+ Just id' -> id' -- Return original if
+ Nothing -> id -- it isn't in subst
+
-- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
-- modify function, and put it back.
isEmptyIdSet = isEmptyUniqSet
mkIdSet = mkUniqSet
\end{code}
-
-\begin{code}
-addId, nmbrId, nmbrDataCon :: 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)
-
- -- used when renumbering TyCons to produce data decls...
-nmbrDataCon id@(Id _ _ _ (TupleConId _) _ _) nenv
- = (nenv, id) -- nothing to do for tuples
-
-nmbrDataCon id@(Id u n ty (AlgConId tag marks fields tvs theta con_tvs con_theta arg_tys tc) prag info)
- nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
- = case (lookupUFM_Directly idenv u) of
- Just xx -> trace "nmbrDataCon: in env???\n" (nenv, xx)
- Nothing ->
- let
- (nenv2, new_fields) = (mapNmbr nmbrField fields) nenv
- (nenv3, new_arg_tys) = (mapNmbr nmbrType arg_tys) nenv2
-
- new_det = AlgConId tag marks new_fields (bottom "tvs") (bottom "theta") (bottom "tvs") (bottom "theta") new_arg_tys tc
- new_id = Id u n (bottom "ty") new_det prag info
- in
- (nenv3, new_id)
- where
- bottom msg = panic ("nmbrDataCon"++msg)
-
-------------
-nmbr_details :: IdDetails -> NmbrM IdDetails
-
-nmbr_details (AlgConId tag marks fields tvs theta con_tvs con_theta arg_tys tc)
- = mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs ->
- mapNmbr nmbrTyVar con_tvs `thenNmbr` \ new_con_tvs ->
- mapNmbr nmbrField fields `thenNmbr` \ new_fields ->
- mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
- mapNmbr nmbr_theta con_theta `thenNmbr` \ new_con_theta ->
- mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys ->
- returnNmbr (AlgConId tag marks new_fields new_tvs new_theta new_con_tvs new_con_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)
-\end{code}
projects / ghc-hetmet.git / blobdiff