X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=70963624a9569aef2d5eb5b33fd68b2b755714dc;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=e379b95379f889b59cdde4a82f71a6e00f129102;hpb=ae45ff0e9831a0dc862a5d68d03e355d7e323c62;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index e379b95..7096362 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -6,102 +6,145 @@ \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, - 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, @@ -115,21 +158,22 @@ import Name ( appendRdr, nameUnique, mkLocalName, isLocalName, ) 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, @@ -570,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} @@ -742,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 @@ -797,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} @@ -1050,18 +1038,25 @@ mk_classy_id details str op_str u rec_c ty 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) : map Right (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 mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : map Right (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 = trace "mkWorkerId:origName:" $ origName "mkWorkerId" unwrkr_name + unwrkr_orig = origName "mkWorkerId" unwrkr_name umod = moduleOf unwrkr_orig n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name @@ -1185,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))) @@ -1209,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) + +dataConNumFields id + = ASSERT(isDataCon id) + case (dataConSig id) of { (_, _, arg_tys, _) -> + length arg_tys } -isNullaryDataCon con = dataConArity con == 0 -- function of convenience +isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience addIdArity :: Id -> Int -> Id addIdArity (Id u n ty details pinfo info) arity @@ -1250,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 @@ -1274,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 @@ -1446,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)? @@ -1461,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 @@ -1538,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. @@ -1676,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 @@ -1704,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} @@ -1740,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 @@ -1770,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 @@ -1781,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