\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,
)
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,
isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
isWorkerId other = False
-{-LATER:
isWrapperId id = workerExists (getIdStrictness id)
--}
\end{code}
\begin{code}
-> Bool -- mentions this Id. Reason: it cannot
-- possibly be seen in another module.
-unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
-{-LATER:
-
-unfoldingUnfriendlyId id
- | not (externallyVisibleId id) -- that settles that...
- = True
-
-unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper) _ _)
- = class_thing wrapper
- where
- -- "class thing": If we're going to use this worker Id in
- -- an interface, we *have* to be able to untangle the wrapper's
- -- strictness when reading it back in. At the moment, this
- -- is not always possible: in precisely those cases where
- -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
-
- class_thing (Id _ _ _ (SuperDictSelId _ _) _ _) = True
- class_thing (Id _ _ _ (MethodSelId _ _) _ _) = True
- class_thing (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
- class_thing other = False
-
-unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _) _ _)
- -- a SPEC of a DictFunId can end up w/ gratuitous
- -- TyVar(Templates) in the i/face; only a problem
- -- if -fshow-pragma-name-errs; but we can do without the pain.
- -- A HACK in any case (WDP 94/05/02)
- = 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
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}
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
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)))
\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
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
`addInfo` mkArityInfo arity
--ToDo: `addInfo` specenv
- arity = length args_tys
+ arity = length ctxt + length args_tys
unfolding
= noInfo_UF
%************************************************************************
@getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
-and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
-@TyVars@ don't really have to be new, because we are only producing a
-template.
+and generates an @Unfolding@. The @Ids@ and @TyVars@ don't really
+have to be new, because we are only producing a template.
ToDo: what if @DataConId@'s type has a context (haven't thought about it
--WDP)?
present.)
\begin{code}
-getIdUnfolding :: Id -> UnfoldingDetails
+getIdUnfolding :: Id -> Unfolding
getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
{-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
\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.
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
-- 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}
\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
Just xx -> (nenv, xx)
Nothing ->
if not (toplevelishId id) then
- _trace "nmbrId: lookup failed" $
+ trace "nmbrId: lookup failed" $
(nenv, id)
else
let
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
projects / ghc-hetmet.git / blobdiff