X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=70963624a9569aef2d5eb5b33fd68b2b755714dc;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=5704027260659093f84bb732fe0fb539ed5d58e5;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 5704027..7096362 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -6,130 +6,174 @@ \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, dataConStrictMarks, - dataConSig, dataConRawArgTys, dataConArgTys, - dataConTyCon, dataConArity, + dataConArgTys, + dataConArity, + dataConNumFields, dataConFieldLabels, + dataConRawArgTys, + dataConSig, + dataConStrictMarks, + dataConTag, + dataConTyCon, recordSelectorFieldLabel, -- PREDICATES - isDataCon, isTupleCon, - isNullaryDataCon, - isSpecId_maybe, isSpecPragmaId_maybe, - toplevelishId, externallyVisibleId, - isTopLevId, isWorkerId, isWrapperId, - isImportedId, isSysLocalId, - isBottomingId, - isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe, - isDictFunId, ---??? isInstId_maybe, - isConstMethodId_maybe, + 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, - showId, - pprIdInUnfolding, - + applyTypeEnvToId, + apply_to_Id, + + -- PRINTING and RENUMBERING + addId, + nmbrDataCon, nmbrId, + pprId, + showId, - -- "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 + -- 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 ( classOpString, 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 Name ( appendRdr, nameUnique, mkLocalName, isLocalName, - isLocallyDefinedName, isPreludeDefinedName, + isLocallyDefinedName, mkTupleDataConName, mkCompoundName, mkCompoundName2, - isLexSym, isLexSpecialSym, getLocalName, - isLocallyDefined, isPreludeDefined, changeUnique, - getOccName, moduleNamePair, origName, nameOf, + isLexSym, isLexSpecialSym, + isLocallyDefined, changeUnique, + getOccName, origName, moduleOf, isExported, ExportFlag(..), RdrName(..), Name ) import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} ) import PragmaInfo ( PragmaInfo(..) ) -import PprEnv -- ( NmbrM(..), NmbrEnv(..) ) +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 Unique ( getBuiltinUniques, pprUnique, showUnique, @@ -183,8 +227,6 @@ data IdDetails | ImportedId -- Global name (Imported or Implicit); Id imported from an interface - | PreludeId -- Global name (Builtin); Builtin prelude Ids - | TopLevId -- Global name (LocalDef); Top-level in the orig source pgm -- (not moved there by transformations). @@ -237,7 +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. - (Maybe Module) -- module where instance came from; Nothing => Prelude + Module -- module where instance came from -- see below | ConstMethodId -- A method which depends only on the type of the @@ -245,7 +287,7 @@ data IdDetails Class -- Uniquely identified by: Type -- (class, type, classop) triple ClassOp - (Maybe Module) -- module where instance came from; Nothing => Prelude + Module -- module where instance came from | InstId -- An instance of a dictionary, class operation, -- or overloaded value (Local name) @@ -358,9 +400,6 @@ 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 @Name@). It does {\em not} include those which are moved to the @@ -499,7 +538,6 @@ toplevelishId (Id _ _ _ details _ _) chk (TupleConId _) = True chk (RecordSelId _) = True chk ImportedId = True - chk PreludeId = True chk TopLevId = True -- NB: see notes chk (SuperDictSelId _ _) = True chk (MethodSelId _ _) = True @@ -521,7 +559,6 @@ idHasNoFreeTyVars (Id _ _ _ details _ info) chk (TupleConId _) = True chk (RecordSelId _) = True chk ImportedId = True - chk PreludeId = True chk TopLevId = True chk (SuperDictSelId _ _) = True chk (MethodSelId _ _) = True @@ -577,9 +614,7 @@ isSuperDictSelId_maybe other_id = Nothing isWorkerId (Id _ _ _ (WorkerId _) _ _) = True isWorkerId other = False -{-LATER: isWrapperId id = workerExists (getIdStrictness id) --} \end{code} \begin{code} @@ -608,7 +643,6 @@ pprIdInUnfolding in_scopes v case v_details of -- these ones must have been exported by their original module ImportedId -> pp_full_name - PreludeId -> pp_full_name -- these ones' exportedness checked later... TopLevId -> pp_full_name @@ -653,7 +687,7 @@ pprIdInUnfolding in_scopes v pp_full_name = let - (m_str, n_str) = moduleNamePair v + (OrigName m_str n_str) = origName "Id:ppr_Unfolding" v pp_n = if isLexSym n_str && not (isLexSpecialSym n_str) then @@ -750,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 _ _ _) = panic "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 @@ -805,30 +800,15 @@ externallyVisibleId :: Id -> Bool 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} @@ -877,7 +857,7 @@ unlocaliseId mod (Id u name ty info (InstId no_ftvs)) -- 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 @@ -1038,42 +1018,48 @@ getInstIdModule other = panic "Id:getInstIdModule" \begin{code} mkSuperDictSelId u c sc ty info - = Id u n ty (SuperDictSelId c sc) NoPragmaInfo info - where - cname = getName c -- we get other info out of here - - n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname + = mk_classy_id (SuperDictSelId c sc) SLIT("sdsel") (Left (origName "mkSuperDictSelId" sc)) u c ty info mkMethodSelId u rec_c op ty info - = Id u n ty (MethodSelId rec_c op) NoPragmaInfo info - where - cname = getName rec_c -- we get other info out of here - - n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname + = 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 - = Id u n ty (DefaultMethodId rec_c op gen) NoPragmaInfo info + = mk_classy_id (DefaultMethodId rec_c op gen) SLIT("defm") (Right (classOpString op)) u rec_c ty info + +mk_classy_id details str op_str u rec_c ty info + = Id u n ty details NoPragmaInfo info where cname = getName rec_c -- we get other info out of here + cname_orig = origName "mk_classy_id" cname + cmod = moduleOf cname_orig - n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname + 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 SLIT("dfun") [origName c] (getTypeString ity) from_here locn + 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 SLIT("const") [origName c, Unqual (classOpString op)] (getTypeString ity) from_here locn + 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) + ) 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 SLIT("wrk") [origName unwrkr_name] unwrkr_name + 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 @@ -1104,7 +1090,6 @@ getConstMethodId clas op ty \begin{code} mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info -mkPreludeId n ty info = Id (nameUnique n) n ty PreludeId NoPragmaInfo info {-LATER: updateIdType :: Id -> Type -> Id @@ -1195,11 +1180,11 @@ getPragmaInfo :: GenId ty -> PragmaInfo getIdInfo (Id _ _ _ _ _ info) = info getPragmaInfo (Id _ _ _ _ info _) = info -{-LATER: replaceIdInfo :: Id -> IdInfo -> Id -replaceIdInfo (Id u n ty _ details) info = Id u n ty info details +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))) @@ -1219,16 +1204,24 @@ 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, dataConNumFields :: DataCon -> Int -dataConArity :: DataCon -> Int dataConArity id@(Id _ _ _ _ _ id_info) = ASSERT(isDataCon id) case (arityMaybe (getInfo id_info)) of - Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id) Just i -> i + Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id) -isNullaryDataCon con = dataConArity con == 0 -- function of convenience +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 n ty details pinfo info) arity @@ -1260,7 +1253,7 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon n type_of_constructor (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon) - NoPragmaInfo + IWantToBeINLINEd -- Always inline constructors if possible datacon_info data_con_tag = position_within fIRST_TAG data_con_family @@ -1284,7 +1277,7 @@ mkDataCon 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 @@ -1456,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)? @@ -1471,16 +1463,16 @@ 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 {-LATER: -addIdUnfolding :: Id -> UnfoldingDetails -> Id +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 @@ -1548,14 +1540,12 @@ addIdFBTypeInfo (Id u n ty info details) upd_info \end{code} \begin{code} -{- LATER: getIdSpecialisation :: Id -> SpecEnv getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info addIdSpecialisation :: Id -> SpecEnv -> Id addIdSpecialisation (Id u n ty details prags info) spec_info = Id u n ty details prags (info `addInfo` spec_info) --} \end{code} Strictness: we snaffle the info out of the IdInfo. @@ -1642,23 +1632,6 @@ 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} Default printing code (not used for interfaces): @@ -1677,53 +1650,6 @@ instance Uniquable (GenId ty) where instance NamedThing (GenId ty) where getName this_id@(Id u n _ details _ _) = n -{- OLD: - = get details - where - get (LocalId _) = n - get (SysLocalId _) = n - get (SpecPragmaId _ _) = n - get ImportedId = n - get PreludeId = n - get TopLevId = n - get (InstId n _) = n - get (DataConId _ _ _ _ _ _ _) = n - get (TupleConId _) = n - get (RecordSelId l) = getName l - get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id) --} -{- LATER: - get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ??? - mod -> (mod, classOpString op) - - get (SpecId unspec ty_maybes _) - = case moduleNamePair unspec of { (mod, unspec_nm) -> - case specMaybeTysSuffix ty_maybes of { tys_suffix -> - (mod, - unspec_nm _APPEND_ - (if not (toplevelishId unspec) - then showUnique u - else tys_suffix) - ) }} - - get (WorkerId unwrkr) - = case moduleNamePair unwrkr of { (mod, unwrkr_nm) -> - (mod, - unwrkr_nm _APPEND_ - (if not (toplevelishId unwrkr) - then showUnique u - else SLIT(".wrk")) - ) } - - 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) - - = case (getIdNamePieces True this_id) of { (piece1:pieces) -> - case [ _CONS_ '.' p | p <- pieces ] of { dotted_pieces -> - (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) }} --} \end{code} Note: The code generator doesn't carry a @UniqueSupply@, so it uses @@ -1750,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 @@ -1778,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} @@ -1814,15 +1745,15 @@ mkIdSet = mkUniqSet \end{code} \begin{code} -addId, nmbrId :: Id -> NmbrM Id +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!" $ + Just xx -> trace "addId: already in map!" $ (nenv, xx) Nothing -> if toplevelishId id then - _trace "addId: can't add toplevelish!" $ + trace "addId: can't add toplevelish!" $ (nenv, id) else -- alloc a new unique for this guy -- and add an entry in the idenv @@ -1844,7 +1775,7 @@ nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) Just xx -> (nenv, xx) Nothing -> if not (toplevelishId id) then - _trace "nmbrId: lookup failed" $ + trace "nmbrId: lookup failed" $ (nenv, id) else let @@ -1855,6 +1786,25 @@ nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) 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