X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=70963624a9569aef2d5eb5b33fd68b2b755714dc;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=6c1d19b87c47e6b88e0e2bcec6104446a19aadb7;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 6c1d19b..7096362 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -6,129 +6,181 @@ \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, - idPrimRep, getInstIdModule, - getMentionedTyConsAndClassesFromId, + idUnique, - dataConTag, - dataConSig, getInstantiatedDataConSig, - dataConTyCon, dataConArity, + 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, 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, + -- Specialialisation + getIdSpecialisation, + addIdSpecialisation, - -- and to make the interface self-sufficient... - GenIdSet(..), IdSet(..) - )-} where - -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 CStrings ( identToC, cSEP ) +import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp ) import IdInfo import Maybes ( maybeToBool ) -import NameTypes ( mkShortName, fromPrelude, FullName, ShortName ) -import FieldLabel ( fieldLabelName, FieldLabel{-instances-} ) -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 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, tyConDataCons ) import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy, - applyTyCon, isPrimType, instantiateTy, + applyTyCon, instantiateTy, tyVarsOfType, applyTypeEnvToTy, typePrimRep, - GenType, ThetaType(..), TauType(..), Type(..) + GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type) ) -import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) ) +import TyVar ( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) ) import UniqFM import UniqSet -- practically all of it -import UniqSupply ( getBuiltinUniques ) -import Unique ( mkTupleDataConUnique, pprUnique, showUnique, +import Unique ( getBuiltinUniques, pprUnique, showUnique, + incrUnique, Unique{-instance Ord3-} ) -import Util ( mapAccumL, nOfThem, +import Util ( mapAccumL, nOfThem, zipEqual, panic, panic#, pprPanic, assertPanic ) \end{code} @@ -146,6 +198,7 @@ ToDo: possibly cache other stuff in the single-constructor @Id@ type. \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 @@ -160,23 +213,21 @@ data IdDetails ---------------- 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 @@ -184,8 +235,7 @@ data IdDetails ---------------- Data constructors - | DataConId FullName - ConTag + | DataConId ConTag [StrictnessMark] -- Strict args; length = arity [FieldLabel] -- Field labels for this constructor @@ -196,7 +246,7 @@ data IdDetails | TupleConId Int -- Its arity - | RecordSelectorId FieldLabel + | RecordSelId FieldLabel ---------------- Things to do with overloading @@ -229,8 +279,7 @@ data IdDetails -- 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 @@ -238,11 +287,10 @@ data IdDetails 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 @@ -257,14 +305,12 @@ data IdDetails | 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 @@ -354,12 +400,9 @@ the infinite family of tuples. 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. @@ -448,134 +491,130 @@ properties, but they may not. \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 (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 (RecordSelectorId _) = True - chk (ImportedId _) = True - chk (PreludeId _) = True - chk (TopLevId _) = True -- NB: see notes + 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 (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 (InstId _) = False -- these are local + chk (LocalId _) = False + chk (SysLocalId _) = False + chk (SpecPragmaId _ _) = False -idHasNoFreeTyVars (Id _ _ details _ info) +idHasNoFreeTyVars (Id _ _ _ details _ info) = chk details where - chk (DataConId _ _ _ _ _ _ _ _) = True - chk (TupleConId _) = True - chk (RecordSelectorId _) = True - chk (ImportedId _) = True - chk (PreludeId _) = True - chk (TopLevId _) = True + chk (DataConId _ _ _ _ _ _ _) = True + chk (TupleConId _) = True + chk (RecordSelId _) = True + chk ImportedId = True + chk TopLevId = True chk (SuperDictSelId _ _) = True chk (MethodSelId _ _) = True chk (DefaultMethodId _ _ _) = True - chk (DictFunId _ _ _ _) = True - chk (ConstMethodId _ _ _ _ _) = True + chk (DictFunId _ _ _) = True + chk (ConstMethodId _ _ _ _) = True chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr - chk (InstId _ no_free_tvs) = no_free_tvs 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) = 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} @@ -588,7 +627,7 @@ pprIdInUnfolding in_scopes v 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 @@ -599,18 +638,17 @@ pprIdInUnfolding in_scopes 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 - DataConId _ _ _ _ _ _ _ _ -> pp_full_name + TopLevId -> pp_full_name + DataConId _ _ _ _ _ _ _ -> pp_full_name - RecordSelectorId lbl -> ppr sty lbl + RecordSelId lbl -> ppr sty lbl -- class-ish things: class already recorded as "mentioned" SuperDictSelId c sc @@ -622,9 +660,9 @@ pprIdInUnfolding in_scopes v -- 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 @@ -649,15 +687,15 @@ pprIdInUnfolding in_scopes v 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] @@ -710,7 +748,7 @@ whatsMentionedInId in_scopes v -- ones to think about: else let - (Id _ _ v_details _ _) = v + (Id _ _ _ v_details _ _) = v in case v_details of -- specialisations and workers @@ -735,7 +773,7 @@ Tell them who my wrapper function is. {-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} @@ -746,46 +784,7 @@ unfoldingUnfriendlyId -- return True iff it is definitely a bad -> Bool -- mentions this Id. Reason: it cannot -- possibly be seen in another module. -unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId" -{-LATER: - -unfoldingUnfriendlyId id - | not (externallyVisibleId id) -- that settles that... - = True - -unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _) - = class_thing wrapper - where - -- "class thing": If we're going to use this worker Id in - -- an interface, we *have* to be able to untangle the wrapper's - -- strictness when reading it back in. At the moment, this - -- is not always possible: in precisely those cases where - -- we pass tcGenPragmas a "Nothing" for its "ty_maybe". - - class_thing (Id _ _ (SuperDictSelId _ _) _ _) = True - class_thing (Id _ _ (MethodSelId _ _) _ _) = True - class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True - class_thing other = False - -unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _) - -- a SPEC of a DictFunId can end up w/ gratuitous - -- TyVar(Templates) in the i/face; only a problem - -- if -fshow-pragma-name-errs; but we can do without the pain. - -- A HACK in any case (WDP 94/05/02) - = naughty_DictFunId dfun - -unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _) - = naughty_DictFunId dfun -- similar deal... - -unfoldingUnfriendlyId other_id = False -- is friendly in all other cases - -naughty_DictFunId :: IdDetails -> Bool - -- True <=> has a TyVar(Template) in the "type" part of its "name" - -naughty_DictFunId (DictFunId _ _ 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 @@ -799,39 +798,24 @@ compiling the prelude, the compiler may not recognise that as true. \begin{code} externallyVisibleId :: Id -> Bool -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... - -{- LATER: if at all: - weird_datacon (DataConId _ _ _ _ _ _ _ tycon) - = maybeToBool (maybePurelyLocalTyCon tycon) --} - weird_datacon not_a_datacon_therefore_not_weird = False - - weird_tuplecon (TupleConId arity) - = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use - weird_tuplecon _ = False \end{code} \begin{code} idWantsToBeINLINEd :: Id -> Bool -idWantsToBeINLINEd (Id _ _ _ IWantToBeINLINEd _) = True -idWantsToBeINLINEd _ = False +idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True +idWantsToBeINLINEd _ = False \end{code} For @unlocaliseId@: See the brief commentary in @@ -841,39 +825,39 @@ 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 no_ftvs)) - = 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 @@ -882,19 +866,19 @@ 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 @@ -913,7 +897,7 @@ type TypeEnv = TyVarEnv Type applyTypeEnvToId :: TypeEnv -> Id -> Id -applyTypeEnvToId type_env id@(Id _ ty _ _ _) +applyTypeEnvToId type_env id@(Id _ _ ty _ _ _) | idHasNoFreeTyVars id = id | otherwise @@ -923,15 +907,13 @@ applyTypeEnvToId type_env id@(Id _ ty _ _ _) \end{code} \begin{code} -apply_to_Id :: (Type -> Type) - -> Id - -> Id +apply_to_Id :: (Type -> Type) -> Id -> Id -apply_to_Id ty_fn (Id u ty details prag info) +apply_to_Id ty_fn (Id u n ty details prag info) = let new_ty = ty_fn ty in - Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info) + 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 @@ -963,14 +945,14 @@ with pointers to the substitution: it {\em must} be single-threaded. {-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 no_ftvs) = case (applySubstToInst subst inst) of { (s2, new_inst) -> @@ -995,104 +977,6 @@ applySubstToId subst id@(Id u ty info details) -} \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) ',' ++ ")" )] - - RecordSelectorId lbl -> panic "getIdNamePieces:RecordSelectorId" - - 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} @@ -1102,7 +986,7 @@ get_fullname_pieces n \begin{code} idType :: GenId ty -> ty -idType (Id _ ty _ _ _) = ty +idType (Id _ _ ty _ _ _) = ty \end{code} \begin{code} @@ -1120,8 +1004,8 @@ idPrimRep i = typePrimRep (idType i) \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} @@ -1133,19 +1017,51 @@ getInstIdModule other = panic "Id:getInstIdModule" %************************************************************************ \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 -mkDictFunId u c ity full_ty from_here modname info - = Id u full_ty (DictFunId c ity from_here modname) NoPragmaInfo 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 -mkConstMethodId u c op ity full_ty from_here modname info - = Id u full_ty (ConstMethodId c ity op from_here modname) NoPragmaInfo 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 -mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info +mk_classy_id details str op_str u rec_c ty info + = Id u n ty details NoPragmaInfo info + where + cname = getName rec_c -- we get other info out of here + cname_orig = origName "mk_classy_id" cname + cmod = moduleOf cname_orig + + n = mkCompoundName u cmod str [Left cname_orig, op_str] cname + +mkDictFunId u c ity full_ty from_here locn mod info + = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info + where + n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : renum_type_string full_ty ity) from_here locn + +mkConstMethodId u c op ity full_ty from_here locn mod info + = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info + where + n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : renum_type_string full_ty ity) from_here locn + +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) + ) -mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo +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 @@ -1173,12 +1089,11 @@ getConstMethodId clas op ty %************************************************************************ \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} @@ -1193,18 +1108,19 @@ no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType 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 -> MyTy a b -> PragmaInfo -> MyId a b -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 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} @@ -1215,35 +1131,35 @@ mkUserId (ValName uniq full) ty pragma_info -- 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 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 -} mkIdWithNewUniq :: Id -> Unique -> Id -mkIdWithNewUniq (Id _ ty details prag info) uniq - = Id uniq ty details prag info +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 @@ -1261,14 +1177,14 @@ mkTemplateLocals tys 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))) @@ -1288,18 +1204,28 @@ besides the code-generator need arity info!) \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 :: DataCon -> Int -dataConArity id@(Id _ _ _ _ id_info) +dataConArity, dataConNumFields :: DataCon -> Int + +dataConArity id@(Id _ _ _ _ _ id_info) = ASSERT(isDataCon id) case (arityMaybe (getInfo id_info)) of - Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id) Just i -> i + 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} %************************************************************************ @@ -1309,25 +1235,25 @@ addIdArity (Id u ty details pinfo info) arity %************************************************************************ \begin{code} -mkDataCon :: Unique{-DataConKey-} - -> FullName +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 fields 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 fields 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 @@ -1351,7 +1277,7 @@ mkDataCon k n stricts fields tvs ctxt args_tys tycon `addInfo` mkArityInfo arity --ToDo: `addInfo` specenv - arity = length args_tys + arity = length ctxt + length args_tys unfolding = noInfo_UF @@ -1363,34 +1289,34 @@ mkDataCon k n stricts fields tvs ctxt args_tys tycon (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon 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. @@ -1402,9 +1328,10 @@ mkDataCon k n stricts fields tvs ctxt args_tys tycon 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 @@ -1426,20 +1353,17 @@ mkTupleCon arity (tyvars, dict_vars, vars) = mk_uf_bits arity 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 @@ -1448,100 +1372,63 @@ fIRST_TAG = 1 -- Tags allocated from here for real constructors \begin{code} dataConTag :: DataCon -> ConTag -- will panic if not a DataCon -dataConTag (Id _ _ (DataConId _ tag _ _ _ _ _ _) _ _) = tag -dataConTag (Id _ _ (TupleConId _) _ _) = fIRST_TAG -dataConTag (Id _ _ (SpecId unspec _ _) _ _) = dataConTag unspec +dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _) _ _) = tag +dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG +dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon -dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon -dataConTyCon (Id _ _ (TupleConId a) _ _) = mkTupleTyCon a +dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon +dataConTyCon (Id _ _ _ (TupleConId a) _ _) = mkTupleTyCon a dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon) -- will panic if not a DataCon -dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _) +dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _) = (tyvars, theta_ty, arg_tys, tycon) -dataConSig (Id _ _ (TupleConId arity) _ _) +dataConSig (Id _ _ _ (TupleConId arity) _ _) = (tyvars, [], tyvar_tys, mkTupleTyCon arity) where tyvars = take arity alphaTyVars tyvar_tys = mkTyVarTys tyvars dataConFieldLabels :: DataCon -> [FieldLabel] -dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields +dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields +dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = [] + +dataConStrictMarks :: DataCon -> [StrictnessMark] +dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts +dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _) + = nOfThem arity NotMarkedStrict + +dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience +dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys } + +dataConArgTys :: DataCon + -> [Type] -- Instantiated at these types + -> [Type] -- Needs arguments of these types +dataConArgTys con_id inst_tys + = map (instantiateTy tenv) arg_tys + where + (tyvars, _, arg_tys, _) = dataConSig con_id + tenv = zipEqual "dataConArgTys" tyvars inst_tys \end{code} \begin{code} -mkRecordSelectorId field_label selector_ty - = Id (getItsUnique name) +mkRecordSelId field_label selector_ty + = Id (nameUnique name) + name selector_ty - (RecordSelectorId field_label) + (RecordSelId field_label) NoPragmaInfo noIdInfo where name = fieldLabelName field_label recordSelectorFieldLabel :: Id -> FieldLabel -recordSelectorFieldLabel (Id _ _ (RecordSelectorId lbl) _ _) = lbl +recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl \end{code} -{- LATER -dataConTyCon (Id _ _ _ (SpecId unspec tys _)) - = mkSpecTyCon (dataConTyCon unspec) tys - -dataConSig (Id _ _ _ (SpecId unspec ty_maybes _)) - = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon) - where - (tyvars, theta_ty, arg_tys, tycon) = dataConSig unspec - - ty_env = tyvars `zip` ty_maybes - - spec_tyvars = foldr nothing_tyvars [] ty_env - nothing_tyvars (tyvar, Nothing) l = tyvar : l - nothing_tyvars (tyvar, Just ty) l = l - - 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 "dataConSig:ThetaTy:SpecDataCon" - spec_tycon = mkSpecTyCon tycon ty_maybes --} -\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) = dataConSig data_con - - inst_env = ASSERT(length tvs == length inst_tys) - tvs `zip` inst_tys - - 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) -\end{code} Data type declarations are of the form: \begin{verbatim} @@ -1562,9 +1449,8 @@ Notice the ``big lambdas'' and type arguments to @Con@---we are producing %************************************************************************ @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)? @@ -1577,22 +1463,22 @@ dictionaries, in the even of an overloaded data-constructor---none at 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} @@ -1615,53 +1501,51 @@ class Foo a { op :: Complex b => c -> b -> a } \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. @@ -1669,12 +1553,12 @@ 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} %************************************************************************ @@ -1686,7 +1570,7 @@ addIdStrictness (Id u ty details prags info) strict_info 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} @@ -1695,15 +1579,15 @@ instance Ord3 (GenId ty) where 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 @@ -1724,12 +1608,12 @@ 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 _) _ _) +cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _) = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2" -cmpEqDataCon _ (Id _ _ (SpecId _ _ _) _ _) = LT_ -cmpEqDataCon (Id _ _ (SpecId _ _ _) _ _) _ = GT_ -cmpEqDataCon _ _ = EQ_ +cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_ +cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_ +cmpEqDataCon _ _ = EQ_ \end{code} %************************************************************************ @@ -1748,263 +1632,28 @@ instance Outputable {-Id, i.e.:-}(GenId Type) where 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 maybeAppDataTyCon 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 - = 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 (RecordSelectorId l) = getExportFlag l - 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 (RecordSelectorId l) = isLocallyDefined l - 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 (RecordSelectorId l)= getOrigName l - 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 (RecordSelectorId l)= getOccurrenceName l - 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 (RecordSelectorId l)= getSrcLoc l - 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 (RecordSelectorId l) = fromPreludeCore l - 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. %************************************************************************ %* * @@ -2027,7 +1676,7 @@ delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b -modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a +modifyIdEnv :: (a -> a) -> IdEnv a -> GenId ty -> IdEnv a rngIdEnv :: IdEnv a -> [a] isNullIdEnv :: IdEnv a -> Bool @@ -2055,10 +1704,15 @@ lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx } -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the -- modify function, and put it back. -modifyIdEnv env mangle_fn key +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} @@ -2089,3 +1743,88 @@ 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}