\begin{code}
#include "HsVersions.h"
-module Id {- (
- GenId, Id(..), -- Abstract
- StrictnessMark(..), -- An enumaration
- ConTag(..), DictVar(..), DictFun(..), DataCon(..),
+module Id (
+ -- TYPES
+ GenId(..), -- *naughtily* used in some places (e.g., TcHsSyn)
+ SYN_IE(Id), IdDetails,
+ StrictnessMark(..),
+ SYN_IE(ConTag), fIRST_TAG,
+ SYN_IE(DataCon), SYN_IE(DictFun), SYN_IE(DictVar),
-- CONSTRUCTION
- mkSysLocal, mkUserLocal,
- mkSpecPragmaId,
- mkSpecId, mkSameSpecCon,
- selectIdInfoForSpecId,
- mkTemplateLocals,
- mkImported, mkPreludeId,
- mkDataCon, mkTupleCon,
+ mkConstMethodId,
+ mkDataCon,
+ mkDefaultMethodId,
+ mkDictFunId,
mkIdWithNewUniq,
- mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
- mkConstMethodId, getConstMethodId,
-
- updateIdType,
- mkId, mkDictFunId, mkInstId,
+ mkImported,
+ mkInstId,
+ mkMethodSelId,
+ mkRecordSelId,
+ mkSuperDictSelId,
+ mkSysLocal,
+ mkTemplateLocals,
+ mkTupleCon,
+ mkUserId,
+ mkUserLocal,
mkWorkerId,
- localiseId,
- -- DESTRUCTION
+ -- MANGLING
+ unsafeGenId2Id,
+
+ -- DESTRUCTION (excluding pragmatic info)
+ idPrimRep,
idType,
- getIdInfo, replaceIdInfo,
- getPragmaInfo,
- getIdPrimRep, getInstIdModule,
- getMentionedTyConsAndClassesFromId,
- getDataConTag,
- getDataConSig, getInstantiatedDataConSig,
+ idUnique,
- getDataConTyCon,
+ dataConArgTys,
+ dataConArity,
+ dataConNumFields,
+ dataConFieldLabels,
+ dataConRawArgTys,
+ dataConSig,
+ dataConStrictMarks,
+ dataConTag,
+ dataConTyCon,
+
+ recordSelectorFieldLabel,
-- PREDICATES
- isDataCon, isTupleCon,
- isSpecId_maybe, isSpecPragmaId_maybe,
- toplevelishId, externallyVisibleId,
- isTopLevId, isWorkerId, isWrapperId,
- isImportedId, isSysLocalId,
- isBottomingId,
- isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
- isDictFunId,
---??? isInstId_maybe,
- isConstMethodId_maybe,
+ cmpEqDataCon,
+ cmpId,
cmpId_withSpecDataCon,
- myWrapperMaybe,
- whatsMentionedInId,
- unfoldingUnfriendlyId, -- ToDo: rm, eventually
+ externallyVisibleId,
+ idHasNoFreeTyVars,
idWantsToBeINLINEd,
--- dataConMentionsNonPreludeTyCon,
+ isBottomingId,
+ isConstMethodId,
+ isConstMethodId_maybe,
+ isDataCon,
+ isDefaultMethodId,
+ isDefaultMethodId_maybe,
+ isDictFunId,
+ isImportedId,
+ isMethodSelId,
+ isNullaryDataCon,
+ isSpecPragmaId,
+ isSuperDictSelId_maybe,
+ isSysLocalId,
+ isTopLevId,
+ isTupleCon,
+ isWorkerId,
+ isWrapperId,
+ toplevelishId,
+ unfoldingUnfriendlyId,
-- SUBSTITUTION
- applySubstToId, applyTypeEnvToId,
--- not exported: apply_to_Id, -- please don't use this, generally
-
- -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
- getIdArity, getDataConArity, 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,
+ applyTypeEnvToId,
+ apply_to_Id,
+
+ -- PRINTING and RENUMBERING
+ addId,
+ nmbrDataCon,
+ nmbrId,
+ pprId,
showId,
- pprIdInUnfolding,
-
- -- "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
+ -- Specialialisation
+ getIdSpecialisation,
+ addIdSpecialisation,
-import Ubiq
-import IdLoop -- for paranoia checking
-import TyLoop -- for paranoia checking
-import NameLoop -- for paranoia checking
+ -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
+ addIdArity,
+ addIdDemandInfo,
+ addIdStrictness,
+ addIdUpdateInfo,
+ getIdArity,
+ getIdDemandInfo,
+ getIdInfo,
+ getIdStrictness,
+ getIdUnfolding,
+ getIdUpdateInfo,
+ getPragmaInfo,
+ replaceIdInfo,
+
+ -- IdEnvs AND IdSets
+ SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
+ addOneToIdEnv,
+ addOneToIdSet,
+ combineIdEnvs,
+ delManyFromIdEnv,
+ delOneFromIdEnv,
+ elementOfIdSet,
+ emptyIdSet,
+ growIdEnv,
+ growIdEnvList,
+ idSetToList,
+ intersectIdSets,
+ isEmptyIdSet,
+ isNullIdEnv,
+ lookupIdEnv,
+ lookupNoFailIdEnv,
+ mapIdEnv,
+ minusIdSet,
+ mkIdEnv,
+ mkIdSet,
+ modifyIdEnv,
+ modifyIdEnv_Directly,
+ nullIdEnv,
+ rngIdEnv,
+ unionIdSets,
+ unionManyIdSets,
+ unitIdEnv,
+ unitIdSet
+ ) where
+
+IMP_Ubiq()
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+IMPORT_DELOOPER(TyLoop) -- for paranoia checking
import Bag
-import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
+import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp )
import IdInfo
import Maybes ( maybeToBool )
-import NameTypes ( mkShortName, fromPrelude, FullName, ShortName )
-import Name ( Name(..) )
-import Outputable ( isAvarop, isAconop, getLocalName,
- isExported, ExportFlag(..) )
+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 PrelMods ( pRELUDE_BUILTIN )
-import PprType ( GenType, GenTyVar,
- getTypeString, typeMaybeString, specMaybeTysSuffix )
+import PprEnv -- ( SYN_IE(NmbrM), NmbrEnv(..) )
+import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
+ nmbrType, nmbrTyVar,
+ GenType, GenTyVar
+ )
import PprStyle
import Pretty
+import MatchEnv ( MatchEnv )
import SrcLoc ( mkBuiltinSrcLoc )
-import TyCon ( TyCon, mkTupleTyCon, getTyConDataCons )
-import Type ( mkSigmaTy, mkTyVarTy, mkFunTys, mkDictTy,
- applyTyCon, isPrimType, instantiateTy,
- GenType, ThetaType(..), TauType(..), Type(..) )
-import TyVar ( GenTyVar, alphaTyVars )
+import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
+import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
+ applyTyCon, instantiateTy,
+ tyVarsOfType, applyTypeEnvToTy, typePrimRep,
+ GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type)
+ )
+import TyVar ( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) )
import UniqFM
-import UniqSet ( UniqSet(..) )
-import Unique ( Unique, mkTupleDataConUnique, pprUnique, showUnique )
-import Util ( mapAccumL, nOfThem, panic, pprPanic, assertPanic )
+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
\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
---------------- Local values
- = LocalId ShortName -- mentioned by the user
- Bool -- True <=> no free type vars
+ = LocalId Bool -- Local name; mentioned by the user
+ -- True <=> no free type vars
- | SysLocalId ShortName -- made up by the compiler
- Bool -- as for LocalId
+ | SysLocalId Bool -- Local name; made up by the compiler
+ -- as for LocalId
- | SpecPragmaId ShortName -- introduced by the compiler
+ | SpecPragmaId -- Local name; introduced by the compiler
(Maybe Id) -- for explicit specid in pragma
Bool -- as for LocalId
---------------- Global values
- | ImportedId FullName -- Id imported from an interface
-
- | PreludeId FullName -- things < Prelude that compiler "knows" about
+ | ImportedId -- Global name (Imported or Implicit); Id imported from an interface
- | TopLevId FullName -- Top-level in the orig source pgm
+ | 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
---------------- Data constructors
- | DataConId FullName
- ConTag
+ | DataConId ConTag
[StrictnessMark] -- Strict args; length = arity
+ [FieldLabel] -- Field labels for this constructor
[TyVar] [(Class,Type)] [Type] TyCon
-- the type is:
| TupleConId Int -- Its arity
+ | RecordSelId FieldLabel
+
---------------- Things to do with overloading
| SuperDictSelId -- Selector for superclass dictionary
-- The "a" is irrelevant. As it is too painful to
-- actually do comparisons that way, we kindly supply
-- a Unique for that purpose.
- Bool -- True <=> from an instance decl in this mod
- FAST_STRING -- module where instance came from
+ Module -- module where instance came from
-- see below
| ConstMethodId -- A method which depends only on the type of the
Class -- Uniquely identified by:
Type -- (class, type, classop) triple
ClassOp
- Bool -- True <=> from an instance decl in this mod
- FAST_STRING -- module where instance came from
+ Module -- module where instance came from
- | InstId ShortName -- An instance of a dictionary, class operation,
- -- or overloaded value
+ | 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
| 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
\end{code}
-
DictFunIds are generated from instance decls.
\begin{verbatim}
class Foo a where
their @IdInfo@).
%----------------------------------------------------------------------
-\item[@PreludeId@:] ToDo
-
-%----------------------------------------------------------------------
\item[@TopLevId@:] These are values defined at the top-level in this
module; i.e., those which {\em might} be exported (hence, a
-@FullName@). It does {\em not} include those which are moved to the
+@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.
\begin{code}
unsafeGenId2Id :: GenId ty -> Id
-unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i
+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
+ 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 (Id _ _ _ (TupleConId _) _ _) = True
+ is_tuple (Id _ _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
is_tuple other = False
{-LATER:
-isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _)
+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 _) _ _)
+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}
+@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 -> Bool
+idHasNoFreeTyVars :: Id -> Bool
-toplevelishId (Id _ _ details _ _)
+toplevelishId (Id _ _ _ details _ _)
= chk details
where
- chk (DataConId _ _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (ImportedId _) = True
- chk (PreludeId _) = 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 (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 (ImportedId _) = True
- chk (PreludeId _) = True
- chk (TopLevId _) = True
+ chk (TupleConId _) = True
+ chk (RecordSelId _) = True
+ chk ImportedId = True
+ chk TopLevId = True
chk (SuperDictSelId _ _) = True
- chk (MethodSelId _ _) = True
+ chk (MethodSelId _ _) = True
chk (DefaultMethodId _ _ _) = True
- chk (DictFunId _ _ _ _) = True
- chk (ConstMethodId _ _ _ _ _) = True
+ chk (DictFunId _ _ _) = True
+ chk (ConstMethodId _ _ _ _) = True
chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
- chk (InstId _) = False -- these are local
chk (SpecId _ _ 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 (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
+isTopLevId (Id _ _ _ TopLevId _ _) = True
+isTopLevId other = False
-isImportedId (Id _ _ (ImportedId _) _ _) = True
-isImportedId other = False
+isImportedId (Id _ _ _ ImportedId _ _) = True
+isImportedId other = False
-isBottomingId (Id _ _ _ _ info) = panic "isBottomingId not implemented"
- -- LATER: bottomIsGuaranteed (getInfo info)
+isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
-isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
+isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True
isSysLocalId other = False
-isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True
+isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True
isSpecPragmaId other = False
-isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True
-isMethodSelId _ = False
+isMethodSelId (Id _ _ _ (MethodSelId _ _) _ _) = True
+isMethodSelId _ = False
-isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True
-isDefaultMethodId other = False
+isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
+isDefaultMethodId other = False
-isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _)
+isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _)
= Just (cls, clsop, err)
isDefaultMethodId_maybe other = Nothing
-isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True
+isDictFunId (Id _ _ _ (DictFunId _ _ _) _ _) = True
isDictFunId other = False
-isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True
+isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True
isConstMethodId other = False
-isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _)
+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 (Id _ _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
isSuperDictSelId_maybe other_id = Nothing
-isWorkerId (Id _ _ (WorkerId _) _ _) = True
+isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
isWorkerId other = False
-{-LATER:
isWrapperId id = workerExists (getIdStrictness id)
--}
\end{code}
\begin{code}
in
-- local vars first:
if v `elementOfUniqSet` in_scopes then
- pprUnique (getItsUnique v)
+ 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 (getDataConArity v))
+ ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
-- ones to think about:
else
let
- (Id _ _ v_details _ _) = v
+ (Id _ _ _ v_details _ _) = v
in
case v_details of
-- these ones must have been exported by their original module
- ImportedId _ -> pp_full_name
- PreludeId _ -> pp_full_name
+ ImportedId -> pp_full_name
-- these ones' exportedness checked later...
- TopLevId _ -> pp_full_name
+ 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]
-- instance-ish things: should we try to figure out
-- *exactly* which extra instances have to be exported? (ToDo)
- DictFunId c t _ _
+ DictFunId c t _
-> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
- ConstMethodId c t o _ _
+ ConstMethodId c t o _
-> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
-- specialisations and workers
pp_full_name
= let
- (m_str, n_str) = getOrigName v
+ (OrigName m_str n_str) = origName "Id:ppr_Unfolding" v
pp_n =
- if isAvarop n_str || isAconop n_str then
+ if isLexSym n_str && not (isLexSpecialSym n_str) then
ppBesides [ppLparen, ppPStr n_str, ppRparen]
else
ppPStr n_str
in
- if fromPreludeCore v then
+ if isPreludeDefined v then
pp_n
else
ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
-- ones to think about:
else
let
- (Id _ _ v_details _ _) = v
+ (Id _ _ _ v_details _ _) = v
in
case v_details of
-- specialisations and workers
{-LATER:
myWrapperMaybe :: Id -> Maybe Id
-myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
+myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
myWrapperMaybe other_id = Nothing
-}
\end{code}
-> 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)
- = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
- naughty_DictFunId dfun
- --)
-
-unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
- = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug 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 _ _ False _) = False -- came from outside; must be OK
-naughty_DictFunId (DictFunId _ ty _ _)
- = not (isGroundTy ty)
--}
+unfoldingUnfriendlyId id = not (externallyVisibleId id)
\end{code}
@externallyVisibleId@: is it true that another module might be
\begin{code}
externallyVisibleId :: Id -> Bool
-externallyVisibleId id = panic "Id.externallyVisibleId"
-{-LATER:
-
-externallyVisibleId id@(Id _ _ details _ _)
+externallyVisibleId id@(Id _ _ _ details _ _)
= if isLocallyDefined id then
- toplevelishId id && isExported id && not (weird_datacon details)
+ toplevelishId id && (isExported id || isDataCon id)
+ -- NB: the use of "isExported" is most dodgy;
+ -- We may eventually move to a situation where
+ -- every Id is "externallyVisible", even if the
+ -- module system's namespace control renders it
+ -- "not exported".
else
- not (weird_tuplecon details)
+ True
-- 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...
-
- 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}
\begin{code}
-{-LATER:
idWantsToBeINLINEd :: Id -> Bool
-idWantsToBeINLINEd id
- = case (getIdUnfolding id) of
- IWantToBeINLINEd _ -> True
- _ -> False
--}
+idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
+idWantsToBeINLINEd _ = False
\end{code}
For @unlocaliseId@: See the brief commentary in
{-LATER:
unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
-unlocaliseId mod (Id u ty info (TopLevId fn))
- = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
+unlocaliseId mod (Id u fn ty info TopLevId)
+ = Just (Id u (unlocaliseFullName fn) ty info TopLevId)
-unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
+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 ty info (TopLevId full_name))
+ Just (Id u full_name ty info TopLevId)
-unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
+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 ty info (TopLevId full_name))
+ Just (Id u full_name ty info TopLevId)
-unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
+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 ty info (SpecId xx ty_maybes no_ftvs))
+ Just xx -> Just (Id u n ty info (SpecId xx ty_maybes no_ftvs))
-unlocaliseId mod (Id u ty info (WorkerId unwrkr))
+unlocaliseId mod (Id u n ty info (WorkerId unwrkr))
= case unlocalise_parent mod u unwrkr of
Nothing -> Nothing
- Just xx -> Just (Id u ty info (WorkerId xx))
+ Just xx -> Just (Id u n ty info (WorkerId xx))
-unlocaliseId mod (Id u ty info (InstId name))
- = Just (Id u ty info (TopLevId full_name))
+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 = getLocalName name
+ 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 _ ty info (LocalId sn no_ftvs))
+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 ty info (TopLevId full_name))
+ Just (Id uniq full_name ty info TopLevId)
-unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
+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 ty info (TopLevId full_name))
+ Just (Id uniq full_name ty info TopLevId)
unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
-- we're OK otherwise
former ``should be'' the usual crunch point.
\begin{code}
-{-LATER:
+type TypeEnv = TyVarEnv Type
+
applyTypeEnvToId :: TypeEnv -> Id -> Id
-applyTypeEnvToId type_env id@(Id u ty info details)
+applyTypeEnvToId type_env id@(Id _ _ ty _ _ _)
| idHasNoFreeTyVars id
= id
| otherwise
= apply_to_Id ( \ ty ->
applyTypeEnvToTy type_env ty
) id
--}
\end{code}
\begin{code}
-{-LATER:
-apply_to_Id :: (Type -> Type)
- -> Id
- -> Id
+apply_to_Id :: (Type -> Type) -> Id -> Id
-apply_to_Id ty_fn (Id u ty info details)
- = Id u (ty_fn ty) (apply_to_IdInfo ty_fn info) (apply_to_details details)
+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 (InstId inst)
- = let
- new_inst = apply_to_Inst ty_fn inst
- in
- InstId new_inst
-
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_ftvs
- -- ToDo: recalc no_ftvs????
+ 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)
WorkerId new_unwrkr
apply_to_details other = other
--}
\end{code}
Sadly, I don't think the one using the magic typechecker substitution
{-LATER:
applySubstToId :: Subst -> Id -> (Subst, Id)
-applySubstToId subst id@(Id u ty info details)
+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 new_ty new_info new_details) }}}
+ (s4, Id u n new_ty new_info new_details) }}}
where
- apply_to_details subst _ (InstId inst)
+ apply_to_details subst _ (InstId inst no_ftvs)
= case (applySubstToInst subst inst) of { (s2, new_inst) ->
- (s2, InstId 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) ->
-}
\end{code}
-\begin{code}
-getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
-getIdNamePieces show_uniqs id
- = get (unsafeGenId2Id id)
- where
- get (Id u _ details _ _)
- = case details of
- DataConId n _ _ _ _ _ _ ->
- case (getOrigName n) of { (mod, name) ->
- if fromPrelude mod then [name] else [mod, name] }
-
- TupleConId 0 -> [SLIT("()")]
- TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )]
-
- ImportedId n -> get_fullname_pieces n
- PreludeId n -> get_fullname_pieces n
- TopLevId n -> get_fullname_pieces n
-
- SuperDictSelId c sc ->
- case (getOrigName c) of { (c_mod, c_name) ->
- case (getOrigName sc) of { (sc_mod, sc_name) ->
- let
- c_bits = if fromPreludeCore c
- then [c_name]
- else [c_mod, c_name]
-
- sc_bits= if fromPreludeCore sc
- then [sc_name]
- else [sc_mod, sc_name]
- in
- [SLIT("sdsel")] ++ c_bits ++ sc_bits }}
-
- MethodSelId clas op ->
- case (getOrigName clas) of { (c_mod, c_name) ->
- case (getClassOpString op) of { op_name ->
- if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name]
- } }
-
- DefaultMethodId clas op _ ->
- case (getOrigName clas) of { (c_mod, c_name) ->
- case (getClassOpString op) of { op_name ->
- if fromPreludeCore clas
- then [SLIT("defm"), op_name]
- else [SLIT("defm"), c_mod, c_name, op_name] }}
-
- DictFunId c ty _ _ ->
- case (getOrigName c) of { (c_mod, c_name) ->
- let
- c_bits = if fromPreludeCore c
- then [c_name]
- else [c_mod, c_name]
-
- ty_bits = getTypeString ty
- in
- [SLIT("dfun")] ++ c_bits ++ ty_bits }
-
-
- ConstMethodId c ty o _ _ ->
- case (getOrigName c) of { (c_mod, c_name) ->
- case (getTypeString ty) of { ty_bits ->
- case (getClassOpString o) of { o_name ->
- case (if fromPreludeCore c
- then []
- else [c_mod, c_name]) of { c_bits ->
- [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
-
- -- if the unspecialised equiv is "top-level",
- -- the name must be concocted from its name and the
- -- names of the types to which specialised...
-
- SpecId unspec ty_maybes _ ->
- get unspec ++ (if not (toplevelishId unspec)
- then [showUnique u]
- else concat (map typeMaybeString ty_maybes))
-
- WorkerId unwrkr ->
- get unwrkr ++ (if not (toplevelishId unwrkr)
- then [showUnique u]
- else [SLIT("wrk")])
-
- LocalId n _ -> let local = getLocalName n in
- if show_uniqs then [local, showUnique u] else [local]
- InstId n -> [getLocalName n, showUnique u]
- SysLocalId n _ -> [getLocalName n, showUnique u]
- SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
-
-get_fullname_pieces :: FullName -> [FAST_STRING]
-get_fullname_pieces n
- = BIND (getOrigName n) _TO_ (mod, name) ->
- if fromPrelude mod
- then [name]
- else [mod, name]
- BEND
-\end{code}
-
%************************************************************************
%* *
\subsection[Id-type-funs]{Type-related @Id@ functions}
\begin{code}
idType :: GenId ty -> ty
-idType (Id _ ty _ _ _) = ty
+idType (Id _ _ ty _ _ _) = ty
\end{code}
\begin{code}
\end{code}
\begin{code}
---getIdPrimRep i = primRepFromType (idType i)
+idPrimRep i = typePrimRep (idType i)
\end{code}
\begin{code}
{-LATER:
-getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
-getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
+getInstIdModule (Id _ _ _ (DictFunId _ _ mod)) = mod
+getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ mod)) = mod
getInstIdModule other = panic "Id:getInstIdModule"
-}
\end{code}
%************************************************************************
\begin{code}
-mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
-mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
-mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
+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
-mkDictFunId u c ity full_ty from_here modname info
- = Id u full_ty (DictFunId c ity from_here modname) NoPragmaInfo info
+ n = mkCompoundName u cmod str [Left cname_orig, op_str] cname
-mkConstMethodId u c op ity full_ty from_here modname info
- = Id u full_ty (ConstMethodId c ity op from_here modname) NoPragmaInfo info
+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) : renum_type_string full_ty ity) from_here locn
-mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
+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) : renum_type_string full_ty ity) from_here locn
-mkInstId uniq ty name = Id uniq ty (InstId name) NoPragmaInfo noIdInfo
+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)
+ )
+
+mkWorkerId u unwrkr ty info
+ = Id u n ty (WorkerId unwrkr) NoPragmaInfo info
+ where
+ unwrkr_name = getName unwrkr
+ unwrkr_orig = 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
in
case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
Just xx -> xx
- Nothing -> error (ppShow 80 (ppAboves [
- ppCat [ppStr "ERROR: getConstMethodId:", ppr PprDebug op,
- ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
+ 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}
%************************************************************************
\begin{code}
-mkImported u n ty info = Id u ty (ImportedId n) NoPragmaInfo info
-mkPreludeId u n ty info = Id u ty (PreludeId n) NoPragmaInfo info
+mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
{-LATER:
updateIdType :: Id -> Type -> Id
-updateIdType (Id u _ info details) ty = Id u ty info details
+updateIdType (Id u n _ info details) ty = Id u n ty info details
-}
\end{code}
\begin{code}
-no_free_tvs ty = panic "Id:no_free_tvs" -- null (extractTyVarsFromTy ty)
+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 -> ty -> SrcLoc -> GenId ty
+mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
mkSysLocal str uniq ty loc
- = Id uniq ty (SysLocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
+ = Id uniq (mkLocalName uniq str True{-emph uniq-} loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
mkUserLocal str uniq ty loc
- = Id uniq ty (LocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
+ = Id uniq (mkLocalName uniq str False{-emph name-} loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
-- mkUserId builds a local or top-level Id, depending on the name given
-mkUserId :: Name -> ty -> PragmaInfo -> GenId ty
-mkUserId (Short uniq short) ty pragma_info
- = Id uniq ty (LocalId short (no_free_tvs ty)) pragma_info noIdInfo
-mkUserId (ValName uniq full) ty pragma_info
- = Id uniq ty
- (if isLocallyDefined full then TopLevId full else ImportedId full)
+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}
-- 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 ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
+ = 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 ty info (SpecId unspec ty_maybes (no_free_tvs ty))
+ 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 ty info details)
+mkSameSpecCon ty_maybes unspec@(Id u n ty info details)
= ASSERT(isDataCon unspec)
ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
- Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
+ Id u n new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
where
new_ty = specialiseTy ty ty_maybes 0
- -- pprTrace "SameSpecCon:Unique:"
- -- (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes]))
-
localiseId :: Id -> Id
-localiseId id@(Id u ty info details)
- = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
+localiseId id@(Id u n ty info details)
+ = Id u (mkShortName name loc) ty info (LocalId (no_free_tvs ty))
where
- name = getOccurrenceName id
+ name = getOccName id
loc = getSrcLoc id
+-}
--- this has to be one of the "local" flavours (LocalId, SysLocalId, InstId)
--- ToDo: it does??? WDP
mkIdWithNewUniq :: Id -> Unique -> Id
-mkIdWithNewUniq (Id _ ty info details) uniq
- = Id uniq ty info new_details
--}
+mkIdWithNewUniq (Id _ n ty details prag info) u
+ = Id u (changeUnique n u) ty details prag info
\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}
-{-LATER:
mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocals tys
- = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc)
+ = 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
+getIdInfo (Id _ _ _ _ _ info) = info
+getPragmaInfo (Id _ _ _ _ info _) = info
-{-LATER:
replaceIdInfo :: Id -> IdInfo -> Id
-replaceIdInfo (Id u ty _ details) info = Id u ty info details
+replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
+{-LATER:
selectIdInfoForSpecId :: Id -> IdInfo
selectIdInfoForSpecId unspec
= ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
\begin{code}
getIdArity :: Id -> ArityInfo
-getIdArity (Id _ _ _ _ id_info) = getInfo id_info
+getIdArity id@(Id _ _ _ _ _ id_info)
+ = --ASSERT( not (isDataCon id))
+ getInfo id_info
+
+dataConArity, dataConNumFields :: DataCon -> Int
-getDataConArity :: DataCon -> Int
-getDataConArity id@(Id _ _ _ _ id_info)
+dataConArity id@(Id _ _ _ _ _ id_info)
= ASSERT(isDataCon id)
case (arityMaybe (getInfo id_info)) of
- Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id)
Just i -> i
+ Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
+
+dataConNumFields id
+ = ASSERT(isDataCon id)
+ case (dataConSig id) of { (_, _, arg_tys, _) ->
+ length arg_tys }
+
+isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
addIdArity :: Id -> Int -> Id
-addIdArity (Id u ty details pinfo info) arity
- = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
+addIdArity (Id u n ty details pinfo info) arity
+ = Id u n ty details pinfo (info `addInfo` (mkArityInfo arity))
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-mkDataCon :: Unique{-DataConKey-}
- -> FullName
- -> [StrictnessMark]
+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 k n stricts tvs ctxt args_tys tycon
+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 k
+ = Id (nameUnique n)
+ n
type_of_constructor
- (DataConId n data_con_tag stricts tvs ctxt args_tys tycon)
- NoPragmaInfo
+ (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
+ IWantToBeINLINEd -- Always inline constructors if possible
datacon_info
data_con_tag = position_within fIRST_TAG data_con_family
- data_con_family = getTyConDataCons tycon
+ data_con_family = tyConDataCons tycon
position_within :: Int -> [Id] -> Int
type_of_constructor
= mkSigmaTy tvs ctxt
- (mkFunTys args_tys (applyTyCon tycon (map mkTyVarTy tvs)))
+ (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
datacon_info = noIdInfo `addInfo_UF` unfolding
`addInfo` mkArityInfo arity
--ToDo: `addInfo` specenv
- arity = length args_tys
+ arity = length ctxt + length args_tys
unfolding
= noInfo_UF
-- else -- do some business...
let
(tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
- tyvar_tys = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
in
- BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
+ 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)
- BEND
+ }
mk_uf_bits tvs ctxt arg_tys tycon
= let
(inst_env, tyvars, tyvar_tys)
= instantiateTyVarTemplates tvs
- (map getItsUnique 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.
- BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
- _TO_ inst_dict_tys ->
- BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys ->
+ 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]
- BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
+ case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars ->
- BIND (splitAt (length ctxt) all_vars) _TO_ (dict_vars, vars) ->
+ case (splitAt (length ctxt) all_vars) of { (dict_vars, vars) ->
(tyvars, dict_vars, vars)
- BEND BEND BEND BEND
+ }}}}
where
-- these are really dubious Types, but they are only to make the
-- binders for the lambdas for tossed-away dicts.
mkTupleCon :: Arity -> Id
mkTupleCon arity
- = Id unique ty (TupleConId arity) NoPragmaInfo tuplecon_info
+ = Id unique n ty (TupleConId arity) NoPragmaInfo tuplecon_info
where
- unique = mkTupleDataConUnique arity
+ 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 = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
tuplecon_info
= noIdInfo `addInfo_UF` unfolding
-- else -- do some business...
let
(tyvars, dict_vars, vars) = mk_uf_bits arity
- tyvar_tys = map mkTyVarTy tyvars
+ tyvar_tys = mkTyVarTys tyvars
in
- BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
-
+ case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
mkUnfolding
EssentialUnfolding -- data constructors
- (mkLam tyvars (dict_vars ++ vars) plain_Con)
- BEND
+ (mkLam tyvars (dict_vars ++ vars) plain_Con) }
mk_uf_bits arity
- = BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
- (tyvars, [], vars)
- BEND
+ = case (mkTemplateLocals tyvar_tys) of { vars ->
+ (tyvars, [], vars) }
where
tyvar_tmpls = take arity alphaTyVars
- (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
+ (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
-}
fIRST_TAG :: ConTag
\end{code}
\begin{code}
-getDataConTag :: DataCon -> ConTag -- will panic if not a DataCon
-getDataConTag (Id _ _ (DataConId _ tag _ _ _ _ _) _ _) = tag
-getDataConTag (Id _ _ (TupleConId _) _ _) = fIRST_TAG
-getDataConTag (Id _ _ (SpecId unspec _ _) _ _) = getDataConTag unspec
+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
-getDataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
-getDataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
-getDataConTyCon (Id _ _ (TupleConId a) _ _) = mkTupleTyCon a
+dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
+dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
+dataConTyCon (Id _ _ _ (TupleConId a) _ _) = mkTupleTyCon a
-getDataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
+dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
-- will panic if not a DataCon
-getDataConSig (Id _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
+dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
= (tyvars, theta_ty, arg_tys, tycon)
-getDataConSig (Id _ _ (TupleConId arity) _ _)
+dataConSig (Id _ _ _ (TupleConId arity) _ _)
= (tyvars, [], tyvar_tys, mkTupleTyCon arity)
where
tyvars = take arity alphaTyVars
- tyvar_tys = map mkTyVarTy tyvars
-\end{code}
+ tyvar_tys = mkTyVarTys tyvars
-{- LATER
-getDataConTyCon (Id _ _ _ (SpecId unspec tys _))
- = mkSpecTyCon (getDataConTyCon unspec) tys
-
-getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
- = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
- where
- (tyvars, theta_ty, arg_tys, tycon) = getDataConSig unspec
+dataConFieldLabels :: DataCon -> [FieldLabel]
+dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields
+dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = []
- ty_env = tyvars `zip` ty_maybes
+dataConStrictMarks :: DataCon -> [StrictnessMark]
+dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts
+dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _)
+ = nOfThem arity NotMarkedStrict
- spec_tyvars = foldr nothing_tyvars [] ty_env
- nothing_tyvars (tyvar, Nothing) l = tyvar : l
- nothing_tyvars (tyvar, Just ty) l = l
+dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
+dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
- spec_env = foldr just_env [] ty_env
- just_env (tyvar, Nothing) l = l
- just_env (tyvar, Just ty) l = (tyvar, ty) : l
- spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
-
- spec_theta_ty = if null theta_ty then []
- else panic "getDataConSig:ThetaTy:SpecDataCon"
- spec_tycon = mkSpecTyCon tycon ty_maybes
--}
+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{pseudocode}
-@getInstantiatedDataConSig@ takes a constructor and some types to which
-it is applied; it returns its signature instantiated to these types.
-
\begin{code}
-getInstantiatedDataConSig ::
- DataCon -- The data constructor
- -- Not a specialised data constructor
- -> [TauType] -- Types to which applied
- -- Must be fully applied i.e. contain all types of tycon
- -> ([TauType], -- Types of dict args
- [TauType], -- Types of regular args
- TauType -- Type of result
- )
-
-getInstantiatedDataConSig data_con inst_tys
- = ASSERT(isDataCon data_con)
- let
- (tvs, theta, arg_tys, tycon) = getDataConSig data_con
-
- inst_env = ASSERT(length tvs == length inst_tys)
- tvs `zip` inst_tys
+mkRecordSelId field_label selector_ty
+ = Id (nameUnique name)
+ name
+ selector_ty
+ (RecordSelId field_label)
+ NoPragmaInfo
+ noIdInfo
+ where
+ name = fieldLabelName field_label
- theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ]
- cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ]
- result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys)
- in
- -- Are the first/third results ever used?
- (theta_tys, cmpnt_tys, result_ty)
+recordSelectorFieldLabel :: Id -> FieldLabel
+recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl
\end{code}
+
Data type declarations are of the form:
\begin{verbatim}
data Foo a b = C1 ... | C2 ... | ... | Cn ...
%************************************************************************
@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.
+and generates an @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)?
present.)
\begin{code}
-getIdUnfolding :: Id -> UnfoldingDetails
+getIdUnfolding :: Id -> Unfolding
-getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info
+getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
{-LATER:
-addIdUnfolding :: Id -> UnfoldingDetails -> Id
-addIdUnfolding id@(Id u ty info details) unfold_details
+addIdUnfolding :: Id -> Unfolding -> Id
+addIdUnfolding id@(Id u n ty info details) unfold_details
= ASSERT(
case (isLocallyDefined id, unfold_details) of
- (_, NoUnfoldingDetails) -> True
+ (_, NoUnfolding) -> True
(True, IWantToBeINLINEd _) -> True
(False, IWantToBeINLINEd _) -> False -- v bad
(False, _) -> True
_ -> False -- v bad
)
- Id u ty (info `addInfo_UF` unfold_details) details
+ Id u n ty (info `addInfo_UF` unfold_details) details
-}
\end{code}
\begin{code}
getIdDemandInfo :: Id -> DemandInfo
-getIdDemandInfo (Id _ _ _ _ info) = getInfo info
+getIdDemandInfo (Id _ _ _ _ _ info) = getInfo info
addIdDemandInfo :: Id -> DemandInfo -> Id
-addIdDemandInfo (Id u ty details prags info) demand_info
- = Id u ty details prags (info `addInfo` demand_info)
+addIdDemandInfo (Id u n ty details prags info) demand_info
+ = Id u n ty details prags (info `addInfo` demand_info)
\end{code}
\begin{code}
getIdUpdateInfo :: Id -> UpdateInfo
-getIdUpdateInfo (Id _ _ _ _ info) = getInfo info
+getIdUpdateInfo (Id _ _ _ _ _ info) = getInfo info
addIdUpdateInfo :: Id -> UpdateInfo -> Id
-addIdUpdateInfo (Id u ty details prags info) upd_info
- = Id u ty details prags (info `addInfo` upd_info)
+addIdUpdateInfo (Id u n ty details prags info) upd_info
+ = Id u n ty details prags (info `addInfo` upd_info)
\end{code}
\begin{code}
{- LATER:
getIdArgUsageInfo :: Id -> ArgUsageInfo
-getIdArgUsageInfo (Id u ty info details) = getInfo info
+getIdArgUsageInfo (Id u n ty info details) = getInfo info
addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
-addIdArgUsageInfo (Id u ty info details) au_info
- = Id u ty (info `addInfo` au_info) details
+addIdArgUsageInfo (Id u n ty info details) au_info
+ = Id u n ty (info `addInfo` au_info) details
-}
\end{code}
\begin{code}
{- LATER:
getIdFBTypeInfo :: Id -> FBTypeInfo
-getIdFBTypeInfo (Id u ty info details) = getInfo info
+getIdFBTypeInfo (Id u n ty info details) = getInfo info
addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
-addIdFBTypeInfo (Id u ty info details) upd_info
- = Id u ty (info `addInfo` upd_info) details
+addIdFBTypeInfo (Id u n ty info details) upd_info
+ = Id u n ty (info `addInfo` upd_info) details
-}
\end{code}
\begin{code}
-{- LATER:
getIdSpecialisation :: Id -> SpecEnv
-getIdSpecialisation (Id _ _ _ _ info) = getInfo info
+getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
addIdSpecialisation :: Id -> SpecEnv -> Id
-addIdSpecialisation (Id u ty details prags info) spec_info
- = Id u ty details prags (info `addInfo` spec_info)
--}
+addIdSpecialisation (Id u n ty details prags info) spec_info
+ = Id u n ty details prags (info `addInfo` spec_info)
\end{code}
Strictness: we snaffle the info out of the IdInfo.
\begin{code}
getIdStrictness :: Id -> StrictnessInfo
-getIdStrictness (Id _ _ _ _ info) = getInfo info
+getIdStrictness (Id _ _ _ _ _ info) = getInfo info
addIdStrictness :: Id -> StrictnessInfo -> Id
-addIdStrictness (Id u ty details prags info) strict_info
- = Id u ty details prags (info `addInfo` strict_info)
+addIdStrictness (Id u n ty details prags info) strict_info
+ = Id u n ty details prags (info `addInfo` 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 _ _ _ _ _) = cmp u1 u2
-- short and very sweet
\end{code}
cmp = cmpId
instance Eq (GenId ty) where
- a == b = case cmpId a b of { EQ_ -> True; _ -> False }
- a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
+ 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 cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+ 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
unspecialised counterpart.
\begin{code}
-{-LATER:
cmpId_withSpecDataCon :: Id -> Id -> TAG_
cmpId_withSpecDataCon id1 id2
cmp_ids = cmpId id1 id2
eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
-cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _)) (Id _ _ _ (SpecId _ mtys2 _))
- = cmpUniTypeMaybeList mtys1 mtys2
-
-cmpEqDataCon unspec1 (Id _ _ _ (SpecId _ _ _))
- = LT_
-
-cmpEqDataCon (Id _ _ _ (SpecId _ _ _)) unspec2
- = GT_
+cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _)
+ = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
-cmpEqDataCon unspec1 unspec2
- = EQ_
--}
+cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_
+cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_
+cmpEqDataCon _ _ = EQ_
\end{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
+
showId :: PprStyle -> Id -> String
showId sty id = ppShow 80 (pprId sty id)
-
--- [used below]
--- for DictFuns (instances) and const methods (instance code bits we
--- can call directly): exported (a) if *either* the class or
--- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
--- class and tycon are from PreludeCore [non-std, but convenient]
--- *and* the thing was defined in this module.
-
-instance_export_flag :: Class -> Type -> Bool -> ExportFlag
-
-instance_export_flag clas inst_ty from_here
- = panic "Id:instance_export_flag"
-{-LATER
- = if instanceIsExported clas inst_ty from_here
- then ExportAll
- else NotExported
--}
-\end{code}
-
-Do we consider an ``instance type'' (as on a @DictFunId@) to be ``from
-PreludeCore''? True if the outermost TyCon is fromPreludeCore.
-\begin{code}
-is_prelude_core_ty :: Type -> Bool
-
-is_prelude_core_ty inst_ty
- = panic "Id.is_prelude_core_ty"
-{- LATER
- = case maybeDataTyCon inst_ty of
- Just (tycon,_,_) -> fromPreludeCore tycon
- Nothing -> panic "Id: is_prelude_core_ty"
--}
\end{code}
Default printing code (not used for interfaces):
\begin{code}
pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
-pprId other_sty id
- = let
- pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
-
- for_code = panic "pprId: for code"
- {- = let
- pieces_to_print -- maybe use Unique only
- = if isSysLocalId id then tail pieces else pieces
- in
- ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
- -}
- in
- case other_sty of
- PprForC -> for_code
- PprForAsm _ _ -> for_code
- PprInterface -> ppPStr occur_name
- PprForUser -> ppPStr occur_name
- PprUnfolding -> qualified_name pieces
- PprDebug -> qualified_name pieces
- PprShowAll -> ppBesides [qualified_name pieces,
- (ppCat [pp_uniq id,
- ppPStr SLIT("{-"),
- ppr other_sty (idType id),
- ppIdInfo other_sty (unsafeGenId2Id id) True
- (\x->x) nullIdEnv (getIdInfo id),
- ppPStr SLIT("-}") ])]
- where
- occur_name = getOccurrenceName id _APPEND_
- ( _PK_ (if not (isSysLocalId id)
- then ""
- else "." ++ (_UNPK_ (showUnique (getItsUnique id)))))
-
- qualified_name pieces
- = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
-
- pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add
- pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = ppNil
- pp_uniq (Id _ _ (TupleConId _) _ _) = ppNil
- pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere
- pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil
- pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil
- pp_uniq (Id _ _ (InstId _) _ _) = ppNil
- pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getItsUnique other_id), ppPStr SLIT("-}")]
-
- -- print PprDebug Ids with # afterwards if they are of primitive type.
- pp_ubxd pretty = pretty
-
-{- LATER: applying isPrimType restricts type
- pp_ubxd pretty = if isPrimType (idType id)
- then ppBeside pretty (ppChar '#')
- else 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}
-instance NamedThing (GenId ty) where
- getExportFlag (Id _ _ details _ _)
- = get details
- where
- get (DataConId _ _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
- get (TupleConId _) = NotExported
- get (ImportedId n) = getExportFlag n
- get (PreludeId n) = getExportFlag n
- get (TopLevId n) = getExportFlag n
- get (SuperDictSelId c _) = getExportFlag c
- get (MethodSelId c _) = getExportFlag c
- get (DefaultMethodId c _ _) = getExportFlag c
- get (DictFunId c ty from_here _) = instance_export_flag c ty from_here
- get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here
- get (SpecId unspec _ _) = getExportFlag unspec
- get (WorkerId unwrkr) = getExportFlag unwrkr
- get (InstId _) = NotExported
- get (LocalId _ _) = NotExported
- get (SysLocalId _ _) = NotExported
- get (SpecPragmaId _ _ _) = NotExported
-
- isLocallyDefined this_id@(Id _ _ details _ _)
- = get details
- where
- get (DataConId _ _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
- get (TupleConId _) = False
- get (ImportedId _) = False
- get (PreludeId _) = False
- get (TopLevId n) = isLocallyDefined n
- get (SuperDictSelId c _) = isLocallyDefined c
- get (MethodSelId c _) = isLocallyDefined c
- get (DefaultMethodId c _ _) = isLocallyDefined c
- get (DictFunId c tyc from_here _) = from_here
- -- For DictFunId and ConstMethodId things, you really have to
- -- know whether it came from an imported instance or one
- -- really here; no matter where the tycon and class came from.
-
- get (ConstMethodId c tyc _ from_here _) = from_here
- get (SpecId unspec _ _) = isLocallyDefined unspec
- get (WorkerId unwrkr) = isLocallyDefined unwrkr
- get (InstId _) = True
- get (LocalId _ _) = True
- get (SysLocalId _ _) = True
- get (SpecPragmaId _ _ _) = True
-
- getOrigName this_id@(Id u _ details _ _)
- = get details
- where
- get (DataConId n _ _ _ _ _ _) = getOrigName n
- get (TupleConId 0) = (pRELUDE_BUILTIN, SLIT("()"))
- get (TupleConId a) = (pRELUDE_BUILTIN, _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" ))
- get (ImportedId n) = getOrigName n
- get (PreludeId n) = getOrigName n
- get (TopLevId n) = getOrigName n
+idUnique (Id u _ _ _ _ _) = u
- get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ???
- (mod, _) -> (mod, getClassOpString op)
+instance Uniquable (GenId ty) where
+ uniqueOf = idUnique
-{- LATER:
- get (SpecId unspec ty_maybes _)
- = BIND getOrigName unspec _TO_ (mod, unspec_nm) ->
- BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
- (mod,
- unspec_nm _APPEND_
- (if not (toplevelishId unspec)
- then showUnique u
- else tys_suffix)
- )
- BEND BEND
-
- get (WorkerId unwrkr)
- = BIND getOrigName unwrkr _TO_ (mod, unwrkr_nm) ->
- (mod,
- unwrkr_nm _APPEND_
- (if not (toplevelishId unwrkr)
- then showUnique u
- else SLIT(".wrk"))
- )
- BEND
--}
-
- get (InstId n) = (panic "NamedThing.Id.getOrigName (LocalId)",
- getLocalName n)
- get (LocalId n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
- getLocalName n)
- get (SysLocalId n _) = (panic "NamedThing.Id.getOrigName (SysLocal)",
- getLocalName n)
- get (SpecPragmaId n _ _)= (panic "NamedThing.Id.getOrigName (SpecPragmaId)",
- getLocalName n)
-
- get other_details
- -- the remaining internally-generated flavours of
- -- Ids really do not have meaningful "original name" stuff,
- -- but we need to make up something (usually for debugging output)
-
- = BIND (getIdNamePieces True this_id) _TO_ (piece1:pieces) ->
- BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
- (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
- BEND BEND
-
- getOccurrenceName this_id@(Id _ _ details _ _)
- = get details
- where
- get (DataConId n _ _ _ _ _ _) = getOccurrenceName n
- get (TupleConId 0) = SLIT("()")
- get (TupleConId a) = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
- get (ImportedId n) = getOccurrenceName n
- get (PreludeId n) = getOccurrenceName n
- get (TopLevId n) = getOccurrenceName n
- get (MethodSelId _ op) = getClassOpString op
- get _ = snd (getOrigName this_id)
-
- getInformingModules id = panic "getInformingModule:Id"
-
- getSrcLoc (Id _ _ details _ id_info)
- = get details
- where
- get (DataConId n _ _ _ _ _ _) = getSrcLoc n
- get (TupleConId _) = mkBuiltinSrcLoc
- get (ImportedId n) = getSrcLoc n
- get (PreludeId n) = getSrcLoc n
- get (TopLevId n) = getSrcLoc n
- get (SuperDictSelId c _)= getSrcLoc c
- get (MethodSelId c _) = getSrcLoc c
- get (SpecId unspec _ _) = getSrcLoc unspec
- get (WorkerId unwrkr) = getSrcLoc unwrkr
- get (InstId n) = getSrcLoc n
- get (LocalId n _) = getSrcLoc n
- get (SysLocalId n _) = getSrcLoc n
- get (SpecPragmaId n _ _)= getSrcLoc n
- -- well, try the IdInfo
- get something_else = getSrcLocIdInfo id_info
-
- getItsUnique (Id u _ _ _ _) = u
-
- fromPreludeCore (Id _ _ details _ _)
- = get details
- where
- get (DataConId _ _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
- get (TupleConId _) = True
- get (ImportedId n) = fromPreludeCore n
- get (PreludeId n) = fromPreludeCore n
- get (TopLevId n) = fromPreludeCore n
- get (SuperDictSelId c _) = fromPreludeCore c
- get (MethodSelId c _) = fromPreludeCore c
- get (DefaultMethodId c _ _) = fromPreludeCore c
- get (DictFunId c t _ _) = fromPreludeCore c && is_prelude_core_ty t
- get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t
- get (SpecId unspec _ _) = fromPreludeCore unspec
- get (WorkerId unwrkr) = fromPreludeCore unwrkr
- get (InstId _) = False
- get (LocalId _ _) = False
- get (SysLocalId _ _) = False
- get (SpecPragmaId _ _ _) = False
+instance NamedThing (GenId ty) where
+ getName this_id@(Id u n _ details _ _) = n
\end{code}
-Reason for @getItsUnique@: The code generator doesn't carry a
-@UniqueSupply@, so it wants to use the @Uniques@ out of local @Ids@
-given to it.
+Note: The code generator doesn't carry a @UniqueSupply@, so it uses
+the @Uniques@ out of local @Ids@ given to it.
%************************************************************************
%* *
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
+modifyIdEnv :: (a -> a) -> IdEnv a -> GenId ty -> IdEnv a
rngIdEnv :: IdEnv a -> [a]
isNullIdEnv :: IdEnv a -> Bool
mkIdEnv = listToUFM
nullIdEnv = emptyUFM
rngIdEnv = eltsUFM
-unitIdEnv = singletonUFM
+unitIdEnv = unitUFM
growIdEnvList env pairs = plusUFM env (listToUFM pairs)
isNullIdEnv env = sizeUFM env == 0
-- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
-- modify function, and put it back.
-modifyIdEnv env mangle_fn key
+modifyIdEnv mangle_fn env key
= case (lookupIdEnv env key) of
Nothing -> env
Just xx -> addOneToIdEnv env key (mangle_fn xx)
+
+modifyIdEnv_Directly mangle_fn env key
+ = case (lookupUFM_Directly env key) of
+ Nothing -> env
+ Just xx -> addToUFM_Directly 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, 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 (DataConId tag marks fields tvs 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 = DataConId tag marks new_fields (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 (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)
\end{code}
projects / ghc-hetmet.git / blobdiff