X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=5f12c46785194c4493b278f15482ef136e9a9bb5;hb=398284dc1582b2f5df9aa8bbd786f3db67d4f4a3;hp=75f15203677acde1dc8b6e65a6b294d4a50a04d2;hpb=f9120c200bcf613b58d742802172fb4c08171f0d;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 75f1520..5f12c46 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -1,141 +1,173 @@ -% + % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[Id]{@Ids@: Value and constructor identifiers} \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) + Id, IdDetails, + StrictnessMark(..), + ConTag, fIRST_TAG, + DataCon, DictFun, DictVar, -- CONSTRUCTION - mkSysLocal, mkUserLocal, - mkSpecPragmaId, - mkSpecId, mkSameSpecCon, - selectIdInfoForSpecId, + mkDataCon, + mkDefaultMethodId, + mkDictFunId, + mkIdWithNewUniq, mkIdWithNewName, mkIdWithNewType, + mkImported, + mkMethodSelId, + mkRecordSelId, + mkSuperDictSelId, + mkSysLocal, mkTemplateLocals, - mkImported, mkPreludeId, - mkDataCon, mkTupleCon, - mkIdWithNewUniq, - mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId, - mkConstMethodId, getConstMethodId, - - updateIdType, - mkId, mkDictFunId, mkInstId, + mkTupleCon, + mkUserId, + mkUserLocal, + mkPrimitiveId, mkWorkerId, - localiseId, + setIdVisibility, - -- DESTRUCTION + -- DESTRUCTION (excluding pragmatic info) + idPrimRep, idType, - getIdInfo, replaceIdInfo, - getPragmaInfo, - idPrimRep, getInstIdModule, - getMentionedTyConsAndClassesFromId, + idUnique, + idName, - dataConTag, - dataConSig, getInstantiatedDataConSig, - dataConTyCon, dataConArity, + dataConRepType, + dataConArgTys, + dataConNumFields, dataConFieldLabels, + dataConRawArgTys, + dataConSig, + dataConStrictMarks, + dataConTag, + dataConTyCon, recordSelectorFieldLabel, -- PREDICATES - isDataCon, isTupleCon, - isSpecId_maybe, isSpecPragmaId_maybe, - toplevelishId, externallyVisibleId, - isTopLevId, isWorkerId, isWrapperId, - isImportedId, isSysLocalId, + omitIfaceSigForId, + cmpId, + externallyVisibleId, + idHasNoFreeTyVars, + idWantsToBeINLINEd, getInlinePragma, + idMustBeINLINEd, idMustNotBeINLINEd, isBottomingId, - isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe, + isDataCon, isAlgCon, isNewCon, + isDefaultMethodId, + isDefaultMethodId_maybe, isDictFunId, ---??? isInstId_maybe, - isConstMethodId_maybe, - cmpId_withSpecDataCon, - myWrapperMaybe, - whatsMentionedInId, - unfoldingUnfriendlyId, -- ToDo: rm, eventually - idWantsToBeINLINEd, --- dataConMentionsNonPreludeTyCon, - - -- 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, + isImportedId, + isRecordSelector, + isDictSelId_maybe, + isNullaryDataCon, + isPrimitiveId_maybe, + isSysLocalId, + isTupleCon, + isWrapperId, + toplevelishId, + unfoldingUnfriendlyId, + + -- PRINTING and RENUMBERING + 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, + setIdSpecialisation, + + -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc) + addIdUnfolding, + addIdArity, + addIdDemandInfo, + addIdStrictness, + addIdUpdateInfo, + getIdArity, + getIdDemandInfo, + getIdInfo, + getIdStrictness, + getIdUnfolding, + getIdUpdateInfo, + getPragmaInfo, + replaceIdInfo, replacePragmaInfo, + addInlinePragma, nukeNoInlinePragma, addNoInlinePragma, + + -- IdEnvs AND IdSets + IdEnv, GenIdSet, IdSet, + addOneToIdEnv, + addOneToIdSet, + combineIdEnvs, + delManyFromIdEnv, + delOneFromIdEnv, + elementOfIdSet, + emptyIdSet, + growIdEnv, + growIdEnvList, + idSetToList, + intersectIdSets, + isEmptyIdSet, + isNullIdEnv, + lookupIdEnv, lookupIdSubst, + lookupNoFailIdEnv, + mapIdEnv, + minusIdSet, + mkIdEnv, elemIdEnv, + mkIdSet, + modifyIdEnv, + modifyIdEnv_Directly, + nullIdEnv, + rngIdEnv, + unionIdSets, + unionManyIdSets, + unitIdEnv, + unitIdSet + ) where - -- and to make the interface self-sufficient... - GenIdSet(..), IdSet(..) - )-} where +#include "HsVersions.h" -import Ubiq -import IdLoop -- for paranoia checking -import TyLoop -- for paranoia checking +import {-# SOURCE #-} CoreUnfold ( Unfolding ) +import {-# SOURCE #-} StdIdInfo ( addStandardIdInfo ) +import CmdLineOpts ( opt_PprStyle_All ) +import SpecEnv ( SpecEnv ) import Bag -import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp ) -import CStrings ( identToC, cSEP ) +import Class ( Class ) +import BasicTypes ( Arity ) import IdInfo import Maybes ( maybeToBool ) -import Name ( appendRdr, nameUnique, mkLocalName, isLocalName, - isLocallyDefinedName, isPreludeDefinedName, - nameOrigName, - RdrName(..), Name - ) -import FieldLabel ( fieldLabelName, FieldLabel{-instances-} ) -import Outputable ( isAvarop, isAconop, getLocalName, - isLocallyDefined, isPreludeDefined, - getOrigName, getOccName, - isExported, ExportFlag(..) - ) +import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName, + mkCompoundName, occNameString, modAndOcc, + changeUnique, isWiredInName, setNameVisibility, + ExportFlag(..), Provenance, + OccName(..), Name, Module, + NamedThing(..) + ) +import PrimOp ( PrimOp ) +import PrelMods ( pREL_TUP, pREL_BASE ) +import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} ) import PragmaInfo ( PragmaInfo(..) ) -import PrelMods ( pRELUDE_BUILTIN ) -import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix, - GenType, GenTyVar - ) -import PprStyle -import Pretty import SrcLoc ( mkBuiltinSrcLoc ) -import TyCon ( TyCon, mkTupleTyCon, tyConDataCons ) -import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy, - applyTyCon, isPrimType, instantiateTy, - tyVarsOfType, applyTypeEnvToTy, typePrimRep, - GenType, ThetaType(..), TauType(..), Type(..) +import TysWiredIn ( tupleTyCon ) +import TyCon ( TyCon, tyConDataCons, isDataTyCon, isNewTyCon, mkSpecTyCon ) +import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, + mkTyConApp, instantiateTy, mkForAllTys, + tyVarsOfType, instantiateTy, typePrimRep, + instantiateTauTy, + GenType, ThetaType, TauType, Type + ) +import TyVar ( TyVar, alphaTyVars, isEmptyTyVarSet, + TyVarEnv, zipTyVarEnv, mkTyVarEnv ) -import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) ) import UniqFM import UniqSet -- practically all of it -import UniqSupply ( getBuiltinUniques ) -import Unique ( mkTupleDataConUnique, pprUnique, showUnique, - Unique{-instance Ord3-} - ) -import Util ( mapAccumL, nOfThem, - panic, panic#, pprPanic, assertPanic - ) +import Unique ( getBuiltinUniques, Unique, Uniquable(..) ) +import Outputable +import SrcLoc ( SrcLoc ) +import Util ( nOfThem, assoc ) +import GlaExts ( Int# ) \end{code} Here are the @Id@ and @IdDetails@ datatypes; also see the notes that @@ -151,13 +183,14 @@ 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 -- eg specialise-me, inline-me IdInfo -- Properties of this Id deduced by compiler -type Id = GenId Type +type Id = GenId Type data StrictnessMark = MarkedStrict | NotMarkedStrict @@ -165,103 +198,56 @@ data IdDetails ---------------- Local values - = LocalId Name -- Local name; mentioned by the user - Bool -- True <=> no free type vars + = LocalId Bool -- Local name; mentioned by the user + -- True <=> no free type vars - | SysLocalId Name -- Local name; made up by the compiler - Bool -- as for LocalId + | SysLocalId Bool -- Local name; made up by the compiler + -- as for LocalId - | SpecPragmaId Name -- Local name; introduced by the compiler - (Maybe Id) -- for explicit specid in pragma - Bool -- as for LocalId + | PrimitiveId PrimOp -- The Id for a primitive operation + ---------------- Global values - | ImportedId Name -- Global name (Imported or Implicit); Id imported from an interface - - | PreludeId Name -- Global name (Builtin); Builtin prelude Ids - - | TopLevId Name -- 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 - -- the monomorphism restriction applies. + | ImportedId -- Global name (Imported or Implicit); Id imported from an interface ---------------- Data constructors - | DataConId Name + | AlgConId -- Used for both data and newtype constructors. + -- You can tell the difference by looking at the TyCon ConTag [StrictnessMark] -- Strict args; length = arity - [FieldLabel] -- Field labels for this constructor + [FieldLabel] -- Field labels for this constructor; + --length = 0 (not a record) or arity - [TyVar] [(Class,Type)] [Type] TyCon + [TyVar] ThetaType -- Type vars and context for the data type decl + [TyVar] ThetaType -- Ditto for the context of the constructor, + -- the existentially quantified stuff + [Type] TyCon -- Args and result tycon -- the type is: - -- forall tyvars . theta_ty => + -- forall tyvars1 ++ tyvars2. theta1 ++ theta2 => -- unitype_1 -> ... -> unitype_n -> tycon tyvars - | TupleConId Name - Int -- Its arity + | TupleConId Int -- Its arity | RecordSelId FieldLabel ---------------- Things to do with overloading - | SuperDictSelId -- Selector for superclass dictionary - Class -- The class (input dict) - Class -- The superclass (result dict) - - | MethodSelId Class -- An overloaded class operation, with - -- a fully polymorphic type. Its code - -- just selects a method from the - -- dictionary. The class. - ClassOp -- The operation - - -- NB: The IdInfo for a MethodSelId has all the info about its - -- related "constant method Ids", which are just - -- specialisations of this general one. + | DictSelId -- Selector that extracts a method or superclass from a dictionary + Class -- The class | DefaultMethodId -- Default method for a particular class op Class -- same class, info as MethodSelId - ClassOp -- (surprise, surprise) - Bool -- True <=> I *know* this default method Id - -- is a generated one that just says - -- `error "No default method for "'. -- see below | DictFunId Class -- A DictFun is uniquely identified - Type -- by its class and type; this type has free type vars, + [Type] -- by its class and type; this type has free type vars, -- whose identity is irrelevant. Eg Class = Eq -- Type = Tree a -- 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 - (Maybe Module) -- module where instance came from; Nothing => Prelude - - -- see below - | ConstMethodId -- A method which depends only on the type of the - -- instance, and not on any further dictionaries etc. - Class -- Uniquely identified by: - Type -- (class, type, classop) triple - ClassOp - Bool -- True => from an instance decl in this mod - (Maybe Module) -- module where instance came from; Nothing => Prelude - - | InstId Name -- An instance of a dictionary, class operation, - -- or overloaded value (Local name) - Bool -- as for LocalId - - | SpecId -- A specialisation of another Id - Id -- Id of which this is a specialisation - [Maybe Type] -- Types at which it is specialised; - -- A "Nothing" says this type ain't relevant. - Bool -- True <=> no free type vars; it's not enough - -- to know about the unspec version, because - -- we may specialise to a type w/ free tyvars - -- (i.e., in one of the "Maybe Type" dudes). - - | WorkerId -- A "worker" for some other Id - Id -- Id for which this is a worker type ConTag = Int @@ -270,7 +256,6 @@ type DictFun = Id type DataCon = Id \end{code} - DictFunIds are generated from instance decls. \begin{verbatim} class Foo a where @@ -297,38 +282,6 @@ generates The type variables in the name are irrelevant; we print them as stars. -Constant method ids are generated from instance decls where -there is no context; that is, no dictionaries are needed to -construct the method. Example -\begin{verbatim} - instance Foo Int where - op = ... -\end{verbatim} -Then we get a constant method -\begin{verbatim} - Foo.op.Int = ... -\end{verbatim} - -It is possible, albeit unusual, to have a constant method -for an instance decl which has type vars: -\begin{verbatim} - instance Foo [a] where - op [] ys = True - op (x:xs) ys = False -\end{verbatim} -We get the constant method -\begin{verbatim} - Foo.op.[*] = ... -\end{verbatim} -So a constant method is identified by a class/op/type triple. -The type variables in the type are irrelevant. - - -For Ids whose names must be known/deducible in other modules, we have -to conjure up their worker's names (and their worker's worker's -names... etc) in a known systematic way. - - %************************************************************************ %* * \subsection[Id-documentation]{Documentation} @@ -345,7 +298,7 @@ class method. \begin{description} %---------------------------------------------------------------------- -\item[@DataConId@:] For the data constructors declared by a @data@ +\item[@AlgConId@:] For the data constructors declared by a @data@ declaration. Their type is kept in {\em two} forms---as a regular @Type@ (in the usual place), and also in its constituent pieces (in the ``details''). We are frequently interested in those pieces. @@ -360,27 +313,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 -top-level through program transformations. - -We also guarantee that @TopLevIds@ will {\em stay} at top-level. -Theoretically, they could be floated inwards, but there's no known -advantage in doing so. This way, we can keep them with the same -@Unique@ throughout (no cloning), and, in general, we don't have to be -so paranoid about them. - -In particular, we had the following problem generating an interface: -We have to ``stitch together'' info (1)~from the typechecker-produced -global-values list (GVE) and (2)~from the STG code [which @Ids@ have -what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change} -between (1) and (2), you're sunk! - -%---------------------------------------------------------------------- \item[@MethodSelId@:] A selector from a dictionary; it may select either a method or a dictionary for one of the class's superclasses. @@ -401,15 +333,6 @@ include dictionaries for the immediate superclasses of C at the type (T a b ..). %---------------------------------------------------------------------- -\item[@InstId@:] - -%---------------------------------------------------------------------- -\item[@SpecId@:] - -%---------------------------------------------------------------------- -\item[@WorkerId@:] - -%---------------------------------------------------------------------- \item[@LocalId@:] A purely-local value, e.g., a function argument, something defined in a @where@ clauses, ... --- but which appears in the original program text. @@ -418,11 +341,6 @@ the original program text. \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in the original program text; these are introduced by the compiler in doing its thing. - -%---------------------------------------------------------------------- -\item[@SpecPragmaId@:] Introduced by the compiler to record -Specialisation pragmas. It is dead code which MUST NOT be removed -before specialisation. \end{description} Further remarks: @@ -430,7 +348,7 @@ Further remarks: %---------------------------------------------------------------------- \item -@DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@, +@DataCons@ @TupleCons@, @Importeds@, @SuperDictSelIds@, @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following properties: \begin{itemize} @@ -442,7 +360,7 @@ They are constants, so they are not free variables. (When the STG machine makes a closure, it puts all the free variables in the closure; the above are not required.) \end{itemize} -Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above +Note that @Locals@ and @SysLocals@ {\em may} have the above properties, but they may not. \end{enumerate} @@ -453,297 +371,117 @@ 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 +-- isDataCon returns False for @newtype@ constructors +isDataCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tc) _ _) = isDataTyCon tc +isDataCon (Id _ _ _ (TupleConId _) _ _) = True +isDataCon other = False -isDataCon id = is_data (unsafeGenId2Id id) - where - is_data (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = True - is_data (Id _ _ (TupleConId _ _) _ _) = True - is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec - is_data other = False +isNewCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tc) _ _) = isNewTyCon tc +isNewCon other = False +-- isAlgCon returns True for @data@ or @newtype@ constructors +isAlgCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ _) _ _) = True +isAlgCon (Id _ _ _ (TupleConId _) _ _) = True +isAlgCon other = False -isTupleCon id = is_tuple (unsafeGenId2Id id) - where - 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 _) _ _) - = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - Just (unspec, ty_maybes) -isSpecId_maybe other_id - = Nothing - -isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _) - = Just specid -isSpecPragmaId_maybe other_id - = Nothing --} +isTupleCon (Id _ _ _ (TupleConId _) _ _) = True +isTupleCon other = False \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 (AlgConId _ __ _ _ _ _ _ _) = True + chk (TupleConId _) = True chk (RecordSelId _) = True - chk (ImportedId _) = True - chk (PreludeId _) = True - chk (TopLevId _) = True -- NB: see notes - chk (SuperDictSelId _ _) = True - chk (MethodSelId _ _) = True - chk (DefaultMethodId _ _ _) = True - chk (DictFunId _ _ _ _) = True - chk (ConstMethodId _ _ _ _ _) = True - chk (SpecId unspec _ _) = toplevelishId unspec - -- depends what the unspecialised thing is - chk (WorkerId unwrkr) = toplevelishId unwrkr - chk (InstId _ _) = False -- these are local - chk (LocalId _ _) = False - chk (SysLocalId _ _) = False - chk (SpecPragmaId _ _ _) = False - -idHasNoFreeTyVars (Id _ _ details _ info) + chk ImportedId = True + chk (DictSelId _) = True + chk (DefaultMethodId _) = True + chk (DictFunId _ _) = True + chk (LocalId _) = False + chk (SysLocalId _) = False + chk (PrimitiveId _) = True + +idHasNoFreeTyVars (Id _ _ _ details _ info) = chk details where - chk (DataConId _ _ _ _ _ _ _ _) = True - chk (TupleConId _ _) = True + chk (AlgConId _ _ _ _ _ _ _ _ _) = True + chk (TupleConId _) = True chk (RecordSelId _) = True - chk (ImportedId _) = True - chk (PreludeId _) = True - chk (TopLevId _) = True - chk (SuperDictSelId _ _) = True - chk (MethodSelId _ _) = True - chk (DefaultMethodId _ _ _) = 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 ImportedId = True + chk (DictSelId _) = True + chk (DefaultMethodId _) = True + chk (DictFunId _ _) = True + chk (LocalId no_free_tvs) = no_free_tvs + chk (SysLocalId no_free_tvs) = no_free_tvs + chk (PrimitiveId _) = True + +-- omitIfaceSigForId tells whether an Id's info is implied by other declarations, +-- so we don't need to put its signature in an interface file, even if it's mentioned +-- in some other interface unfolding. + +omitIfaceSigForId + :: Id + -> Bool + +omitIfaceSigForId (Id _ name _ details _ _) + | isWiredInName name + = True + + | otherwise + = case details of + ImportedId -> True -- Never put imports in interface file + (PrimitiveId _) -> True -- Ditto, for primitives + + -- This group is Ids that are implied by their type or class decl; + -- remember that all type and class decls appear in the interface file. + -- The dfun id must *not* be omitted, because it carries version info for + -- the instance decl + (AlgConId _ _ _ _ _ _ _ _ _) -> True + (TupleConId _) -> True + (RecordSelId _) -> True + (DictSelId _) -> True + + other -> False -- Don't omit! + -- NB DefaultMethodIds are not omitted \end{code} \begin{code} -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 (strictnessInfo info) -isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True +isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True isSysLocalId other = False -isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True -isSpecPragmaId other = False - -isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True -isMethodSelId _ = False +isDictSelId_maybe (Id _ _ _ (DictSelId cls) _ _) = Just cls +isDictSelId_maybe _ = Nothing -isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True -isDefaultMethodId other = False +isDefaultMethodId (Id _ _ _ (DefaultMethodId _) _ _) = True +isDefaultMethodId other = False -isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _) - = Just (cls, clsop, err) +isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls) _ _) + = Just cls isDefaultMethodId_maybe other = Nothing -isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True -isDictFunId other = False +isDictFunId (Id _ _ _ (DictFunId _ _) _ _) = True +isDictFunId other = False -isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True -isConstMethodId other = False - -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 other_id = Nothing - -isWorkerId (Id _ _ (WorkerId _) _ _) = True -isWorkerId other = False - -{-LATER: isWrapperId id = workerExists (getIdStrictness id) --} -\end{code} - -\begin{code} -{-LATER: -pprIdInUnfolding :: IdSet -> Id -> Pretty - -pprIdInUnfolding in_scopes v - = let - v_ty = idType v - in - -- local vars first: - if v `elementOfUniqSet` in_scopes then - pprUnique (idUnique v) - - -- ubiquitous Ids with special syntax: - else if v == nilDataCon then - ppPStr SLIT("_NIL_") - else if isTupleCon v then - ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v)) - - -- ones to think about: - else - let - (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 - - -- these ones' exportedness checked later... - TopLevId _ -> pp_full_name - DataConId _ _ _ _ _ _ _ _ -> pp_full_name - - RecordSelId lbl -> ppr sty lbl - - -- class-ish things: class already recorded as "mentioned" - SuperDictSelId c sc - -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc] - MethodSelId c o - -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o] - DefaultMethodId c o _ - -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o] - - -- instance-ish things: should we try to figure out - -- *exactly* which extra instances have to be exported? (ToDo) - DictFunId c t _ _ - -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t] - ConstMethodId c t o _ _ - -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t] - - -- specialisations and workers - SpecId unspec ty_maybes _ - -> let - pp = pprIdInUnfolding in_scopes unspec - in - ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack, - ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes), - ppRbrack] - - WorkerId unwrkr - -> let - pp = pprIdInUnfolding in_scopes unwrkr - in - ppBeside (ppPStr SLIT("_WRKR_ ")) pp - - -- anything else? we're nae interested - other_id -> panic "pprIdInUnfolding:mystery Id" - where - ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding") - - pp_full_name - = let - (m_str, n_str) = getOrigName v - - pp_n = - if isAvarop n_str || isAconop n_str then - ppBesides [ppLparen, ppPStr n_str, ppRparen] - else - ppPStr n_str - in - if isPreludeDefined v then - pp_n - else - ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n] - - pp_class :: Class -> Pretty - pp_class_op :: ClassOp -> Pretty - pp_type :: Type -> Pretty - pp_ty_maybe :: Maybe Type -> Pretty - - pp_class clas = ppr ppr_Unfolding clas - pp_class_op op = ppr ppr_Unfolding op - - pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen] - - pp_ty_maybe Nothing = ppPStr SLIT("_N_") - pp_ty_maybe (Just t) = pp_type t --} -\end{code} - -@whatsMentionedInId@ ferrets out the types/classes/instances on which -this @Id@ depends. If this Id is to appear in an interface, then -those entities had Jolly Well be in scope. Someone else up the -call-tree decides that. - -\begin{code} -{-LATER: -whatsMentionedInId - :: IdSet -- Ids known to be in scope - -> Id -- Id being processed - -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc. - -whatsMentionedInId in_scopes v - = let - v_ty = idType v - - (tycons, clss) - = getMentionedTyConsAndClassesFromType v_ty - - result0 id_bag = (id_bag, tycons, clss) - - result1 ids tcs cs - = (ids `unionBags` unitBag v, -- we add v to "mentioned"... - tcs `unionBags` tycons, - cs `unionBags` clss) - in - -- local vars first: - if v `elementOfUniqSet` in_scopes then - result0 emptyBag -- v not added to "mentioned" - - -- ones to think about: - else - let - (Id _ _ v_details _ _) = v - in - case v_details of - -- specialisations and workers - SpecId unspec ty_maybes _ - -> let - (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec - in - result1 ids2 tcs2 cs2 - - WorkerId unwrkr - -> let - (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr - in - result1 ids2 tcs2 cs2 - - anything_else -> result0 (unitBag v) -- v is added to "mentioned" --} -\end{code} - -Tell them who my wrapper function is. -\begin{code} -{-LATER: -myWrapperMaybe :: Id -> Maybe Id -myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper -myWrapperMaybe other_id = Nothing --} +isPrimitiveId_maybe (Id _ _ _ (PrimitiveId primop) _ _) = Just primop +isPrimitiveId_maybe other = Nothing \end{code} \begin{code} @@ -752,352 +490,22 @@ 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 -able to ``see'' this Id? +able to ``see'' this Id in a code generation sense. That +is, another .o file might refer to this Id. -We need the @toplevelishId@ check as well as @isExported@ for when we -compile instance declarations in the prelude. @DictFunIds@ are -``exported'' if either their class or tycon is exported, but, in -compiling the prelude, the compiler may not recognise that as true. +In tidyCorePgm (SimplCore.lhs) we carefully set each top level thing's +local-ness precisely so that the test here would be easy \begin{code} externallyVisibleId :: Id -> Bool - -externallyVisibleId id@(Id _ _ details _ _) - = if isLocallyDefined id then - toplevelishId id && isExported id && not (weird_datacon details) - else - not (weird_tuplecon details) - -- 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 -\end{code} - -For @unlocaliseId@: See the brief commentary in -\tr{simplStg/SimplStg.lhs}. - -\begin{code} -{-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 ty info (LocalId sn no_ftvs)) - = --false?: ASSERT(no_ftvs) - let - full_name = unlocaliseShortName mod u sn - in - Just (Id u ty info (TopLevId full_name)) - -unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs)) - = --false?: on PreludeGlaST: ASSERT(no_ftvs) - let - full_name = unlocaliseShortName mod u sn - in - Just (Id u ty info (TopLevId full_name)) - -unlocaliseId mod (Id u 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)) - -unlocaliseId mod (Id u ty info (WorkerId unwrkr)) - = case unlocalise_parent mod u unwrkr of - Nothing -> Nothing - Just xx -> Just (Id u ty info (WorkerId xx)) - -unlocaliseId mod (Id u ty info (InstId name no_ftvs)) - = Just (Id u ty info (TopLevId full_name)) - -- type might be wrong, but it hardly matters - -- at this stage (just before printing C) ToDo - where - name = getLocalName name - full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc - -unlocaliseId mod other_id = Nothing - --------------------- --- we have to be Very Careful for workers/specs of --- local functions! - -unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs)) - = --false?: ASSERT(no_ftvs) - let - full_name = unlocaliseShortName mod uniq sn - in - Just (Id uniq ty info (TopLevId full_name)) - -unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs)) - = --false?: ASSERT(no_ftvs) - let - full_name = unlocaliseShortName mod uniq sn - in - Just (Id uniq ty info (TopLevId full_name)) - -unlocalise_parent mod uniq other_id = unlocaliseId mod other_id - -- we're OK otherwise --} -\end{code} - -CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@: -`Top-levelish Ids'' cannot have any free type variables, so applying -the type-env cannot have any effect. (NB: checked in CoreLint?) - -The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the -former ``should be'' the usual crunch point. - -\begin{code} -type TypeEnv = TyVarEnv Type - -applyTypeEnvToId :: TypeEnv -> Id -> Id - -applyTypeEnvToId type_env id@(Id _ ty _ _ _) - | idHasNoFreeTyVars id - = id - | otherwise - = apply_to_Id ( \ ty -> - applyTypeEnvToTy type_env ty - ) id -\end{code} - -\begin{code} -apply_to_Id :: (Type -> Type) - -> Id - -> Id - -apply_to_Id ty_fn (Id u 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) - where - apply_to_details (SpecId unspec ty_maybes no_ftvs) - = let - new_unspec = apply_to_Id ty_fn unspec - new_maybes = map apply_to_maybe ty_maybes - in - SpecId new_unspec new_maybes (no_free_tvs ty) - -- ToDo: gratuitous recalc no_ftvs???? (also InstId) - where - apply_to_maybe Nothing = Nothing - apply_to_maybe (Just ty) = Just (ty_fn ty) - - apply_to_details (WorkerId unwrkr) - = let - new_unwrkr = apply_to_Id ty_fn unwrkr - in - WorkerId new_unwrkr - - apply_to_details other = other +externallyVisibleId id@(Id _ name _ _ _ _) = not (isLocalName name) + -- not local => global => externally visible \end{code} -Sadly, I don't think the one using the magic typechecker substitution -can be done with @apply_to_Id@. Here we go.... - -Strictness is very important here. We can't leave behind thunks -with pointers to the substitution: it {\em must} be single-threaded. - -\begin{code} -{-LATER: -applySubstToId :: Subst -> Id -> (Subst, Id) - -applySubstToId subst id@(Id u 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) }}} - where - apply_to_details subst _ (InstId inst no_ftvs) - = case (applySubstToInst subst inst) of { (s2, new_inst) -> - (s2, InstId new_inst no_ftvs{-ToDo:right???-}) } - - apply_to_details subst new_ty (SpecId unspec ty_maybes _) - = case (applySubstToId subst unspec) of { (s2, new_unspec) -> - case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) -> - (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }} - -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04) - where - apply_to_maybe subst Nothing = (subst, Nothing) - apply_to_maybe subst (Just ty) - = case (applySubstToTy subst ty) of { (s2, new_ty) -> - (s2, Just new_ty) } - - apply_to_details subst _ (WorkerId unwrkr) - = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) -> - (s2, WorkerId new_unwrkr) } - - apply_to_details subst _ other = (subst, other) --} -\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 (nameOrigName n) of { (mod, name) -> - if isPreludeDefinedName n then [name] else [mod, name] } - - TupleConId n _ -> [snd (nameOrigName n)] - - RecordSelId lbl -> panic "getIdNamePieces:RecordSelId" - - 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 isPreludeDefined c - then [c_name] - else [c_mod, c_name] - - sc_bits= if isPreludeDefined 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 isPreludeDefined 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 isPreludeDefined 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 isPreludeDefined 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 isPreludeDefined c - then [c_name] - 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 :: Name -> [FAST_STRING] -get_fullname_pieces n - = BIND (nameOrigName n) _TO_ (mod, name) -> - if isPreludeDefinedName n - then [name] - else [mod, name] - BEND -\end{code} %************************************************************************ %* * @@ -1106,32 +514,15 @@ get_fullname_pieces n %************************************************************************ \begin{code} -idType :: GenId ty -> ty - -idType (Id _ ty _ _ _) = ty -\end{code} - -\begin{code} -{-LATER: -getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class) +idName :: GenId ty -> Name +idName (Id _ n _ _ _ _) = n -getMentionedTyConsAndClassesFromId id - = getMentionedTyConsAndClassesFromType (idType id) --} -\end{code} +idType :: GenId ty -> ty +idType (Id _ _ ty _ _ _) = ty -\begin{code} idPrimRep i = typePrimRep (idType i) \end{code} -\begin{code} -{-LATER: -getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod -getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod -getInstIdModule other = panic "Id:getInstIdModule" --} -\end{code} - %************************************************************************ %* * \subsection[Id-overloading]{Functions related to overloading} @@ -1139,37 +530,41 @@ 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 - -mkDictFunId u c ity full_ty from_here mod info - = Id u full_ty (DictFunId c ity from_here mod) NoPragmaInfo info - -mkConstMethodId u c op ity full_ty from_here mod info - = Id u full_ty (ConstMethodId c ity op from_here mod) NoPragmaInfo info - -mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info - -mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo - -{-LATER: -getConstMethodId clas op ty - = -- constant-method info is hidden in the IdInfo of - -- the class-op id (as mentioned up above). - let - sel_id = getMethodSelId clas op - in - case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of - Just xx -> xx - Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [ - ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids, - ppr PprDebug sel_id], - ppStr "(This can arise if an interface pragma refers to an instance", - ppStr "but there is no imported interface which *defines* that instance.", - ppStr "The info above, however ugly, should indicate what else you need to import." - ]) --} +mkSuperDictSelId :: Unique -> Class -> Int -> Type -> Id + -- The Int is an arbitrary tag to say which superclass is selected + -- So, for + -- class (C a, C b) => Foo a b where ... + -- we get superclass selectors + -- Foo_sc1, Foo_sc2 + +mkSuperDictSelId u clas index ty + = addStandardIdInfo $ + Id u name ty details NoPragmaInfo noIdInfo + where + name = mkCompoundName name_fn u (getName clas) + details = DictSelId clas + name_fn clas_str = clas_str _APPEND_ SLIT("_sc") _APPEND_ (_PK_ (show index)) + + -- For method selectors the clean thing to do is + -- to give the method selector the same name as the class op itself. +mkMethodSelId op_name clas ty + = addStandardIdInfo $ + Id (uniqueOf op_name) op_name ty (DictSelId clas) NoPragmaInfo noIdInfo + +mkDefaultMethodId dm_name rec_c ty + = Id (uniqueOf dm_name) dm_name ty (DefaultMethodId rec_c) NoPragmaInfo noIdInfo + +mkDictFunId dfun_name full_ty clas itys + = Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo + where + details = DictFunId clas itys + +mkWorkerId u unwrkr ty info + = Id u name ty details NoPragmaInfo info + where + details = LocalId (no_free_tvs ty) + name = mkCompoundName name_fn u (getName unwrkr) + name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str \end{code} %************************************************************************ @@ -1179,78 +574,52 @@ getConstMethodId clas op ty %************************************************************************ \begin{code} -mkImported n ty info = Id (nameUnique n) ty (ImportedId n) NoPragmaInfo info -mkPreludeId n ty info = Id (nameUnique n) ty (PreludeId n) NoPragmaInfo info +mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info + +mkPrimitiveId n ty primop + = addStandardIdInfo $ + Id (nameUnique n) n ty (PrimitiveId primop) IMustBeINLINEd noIdInfo + -- The pragma @IMustBeINLINEd@ says that this Id absolutely must be inlined. + -- It's only true for primitives, because we don't want to make a closure for each of them. -{-LATER: -updateIdType :: Id -> Type -> Id -updateIdType (Id u _ info details) ty = Id u ty info details --} \end{code} \begin{code} -type MyTy a b = GenType (GenTyVar a) b -type MyId a b = GenId (MyTy a b) - no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty) -- SysLocal: for an Id being created by the compiler out of thin air... -- UserLocal: an Id with a name the user might recognize... -mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b +mkSysLocal :: FAST_STRING -> Unique -> GenType flexi -> SrcLoc -> GenId (GenType flexi) +mkUserLocal :: OccName -> Unique -> GenType flexi -> SrcLoc -> GenId (GenType flexi) mkSysLocal str uniq ty loc - = Id uniq ty (SysLocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo + = Id uniq (mkSysLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo -mkUserLocal str uniq ty loc - = Id uniq ty (LocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo +mkUserLocal occ uniq ty loc + = Id uniq (mkLocalName uniq occ 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 name ty pragma_info - | isLocalName name - = Id (nameUnique name) ty (LocalId name (no_free_tvs ty)) pragma_info noIdInfo - | otherwise - = Id (nameUnique name) ty - (if isLocallyDefinedName name then TopLevId name else ImportedId name) - pragma_info noIdInfo +mkUserId :: Name -> GenType flexi -> GenId (GenType flexi) +mkUserId name ty + = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo \end{code} - \begin{code} -{-LATER: - --- 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)) - --- 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)) - --- 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) - = ASSERT(isDataCon unspec) - ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - Id u 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)) - where - name = getOccName id - loc = getSrcLoc id --} +-- See notes with setNameVisibility (Name.lhs) +setIdVisibility :: Maybe Module -> Unique -> Id -> Id +setIdVisibility maybe_mod u (Id uniq name ty details prag info) + = Id uniq (setNameVisibility maybe_mod u name) ty details prag info mkIdWithNewUniq :: Id -> Unique -> Id +mkIdWithNewUniq (Id _ n ty details prag info) u + = Id u (changeUnique n u) ty details prag info -mkIdWithNewUniq (Id _ ty details prag info) uniq - = Id uniq ty details prag info +mkIdWithNewName :: Id -> Name -> Id +mkIdWithNewName (Id _ _ ty details prag info) new_name + = Id (uniqueOf new_name) new_name ty details prag info + +mkIdWithNewType :: Id -> Type -> Id +mkIdWithNewType (Id u name _ details pragma info) ty + = Id u name ty details pragma info \end{code} Make some local @Ids@ for a template @CoreExpr@. These have bogus @@ -1268,19 +637,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 n ty details pinfo _) info = Id u n ty details pinfo info -replaceIdInfo (Id u ty _ details) info = Id u ty info details - -selectIdInfoForSpecId :: Id -> IdInfo -selectIdInfoForSpecId unspec - = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - noIdInfo `addInfo_UF` getIdUnfolding unspec --} +replacePragmaInfo :: GenId ty -> PragmaInfo -> GenId ty +replacePragmaInfo (Id u sn ty details _ info) prag = Id u sn ty details prag info \end{code} %************************************************************************ @@ -1295,18 +659,12 @@ besides the code-generator need arity info!) \begin{code} getIdArity :: Id -> ArityInfo -getIdArity (Id _ _ _ _ id_info) = getInfo id_info - -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 - -addIdArity :: Id -> Int -> Id -addIdArity (Id u ty details pinfo info) arity - = Id u ty details pinfo (info `addInfo` (mkArityInfo arity)) +getIdArity id@(Id _ _ _ _ _ id_info) + = arityInfo id_info + +addIdArity :: Id -> ArityInfo -> Id +addIdArity (Id u n ty details pinfo info) arity + = Id u n ty details pinfo (info `addArityInfo` arity) \end{code} %************************************************************************ @@ -1318,170 +676,149 @@ addIdArity (Id u ty details pinfo info) arity \begin{code} mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] - -> [TyVar] -> ThetaType -> [TauType] -> TyCon ---ToDo: -> SpecEnv + -> [TyVar] -> ThetaType + -> [TyVar] -> ThetaType + -> [TauType] -> TyCon -> Id -- can get the tag and all the pieces of the type from the Type -mkDataCon n stricts fields tvs ctxt args_tys tycon +mkDataCon n stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon = ASSERT(length stricts == length args_tys) - data_con + addStandardIdInfo 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 (nameUnique n) - type_of_constructor - (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon) - NoPragmaInfo - datacon_info - - data_con_tag = position_within fIRST_TAG data_con_family + n + data_con_ty + (AlgConId data_con_tag stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon) + IWantToBeINLINEd -- Always inline constructors if possible + noIdInfo + data_con_tag = assoc "mkDataCon" (data_con_family `zip` [fIRST_TAG..]) data_con data_con_family = tyConDataCons tycon - position_within :: Int -> [Id] -> Int - - position_within acc (c:cs) - = if c == data_con then acc else position_within (acc+1) cs -#ifdef DEBUG - position_within acc [] - = panic "mkDataCon: con not found in family" -#endif - - type_of_constructor - = mkSigmaTy tvs ctxt - (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs))) + data_con_ty + = mkSigmaTy (tvs++con_tvs) (ctxt++con_ctxt) + (mkFunTys args_tys (mkTyConApp tycon (mkTyVarTys tvs))) - datacon_info = noIdInfo `addInfo_UF` unfolding - `addInfo` mkArityInfo arity ---ToDo: `addInfo` specenv - arity = length args_tys +mkTupleCon :: Arity -> Name -> Type -> Id +mkTupleCon arity name ty + = addStandardIdInfo tuple_id + where + tuple_id = Id (nameUnique name) name ty + (TupleConId arity) + IWantToBeINLINEd -- Always inline constructors if possible + noIdInfo - unfolding - = noInfo_UF -{- LATER: - = -- if arity == 0 - -- then noIdInfo - -- else -- do some business... - let - (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 -> - - 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) - 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 -> - - -- 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 -> - - BIND (splitAt (length ctxt) all_vars) _TO_ (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. - ctxt_ty (clas, ty) = mkDictTy clas ty --} +fIRST_TAG :: ConTag +fIRST_TAG = 1 -- Tags allocated from here for real constructors \end{code} -\begin{code} -mkTupleCon :: Arity -> Id +dataConNumFields gives the number of actual fields in the +{\em representation} of the data constructor. This may be more than appear +in the source code; the extra ones are the existentially quantified +dictionaries -mkTupleCon arity - = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info - where - n = panic "mkTupleCon: its Name (Id)" - unique = mkTupleDataConUnique arity - ty = mkSigmaTy tyvars [] - (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys)) - tycon = mkTupleTyCon arity - tyvars = take arity alphaTyVars - tyvar_tys = mkTyVarTys tyvars +\begin{code} +dataConNumFields id + = ASSERT( if (isDataCon id) then True else + pprTrace "dataConNumFields" (ppr id) False ) + case (dataConSig id) of { (_, _, _, con_theta, arg_tys, _) -> + length con_theta + length arg_tys } - tuplecon_info - = noIdInfo `addInfo_UF` unfolding - `addInfo` mkArityInfo arity ---LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty" +isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience - unfolding - = noInfo_UF -{- LATER: - = -- if arity == 0 - -- then noIdInfo - -- else -- do some business... - let - (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 -> - - mkUnfolding - EssentialUnfolding -- data constructors - (mkLam tyvars (dict_vars ++ vars) plain_Con) - BEND - - mk_uf_bits arity - = BIND (mkTemplateLocals tyvar_tys) _TO_ vars -> - (tyvars, [], vars) - BEND - where - tyvar_tmpls = take arity alphaTyVars - (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls) --} - -fIRST_TAG :: ConTag -fIRST_TAG = 1 -- Tags allocated from here for real constructors \end{code} + \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 _ _ _ (AlgConId tag _ _ _ _ _ _ _ _) _ _) = tag +dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon -dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon -dataConTyCon (Id _ _ (TupleConId _ a) _ _) = mkTupleTyCon a +dataConTyCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tycon) _ _) = tycon +dataConTyCon (Id _ _ _ (TupleConId a) _ _) = tupleTyCon a -dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon) +dataConSig :: DataCon -> ([TyVar], ThetaType, [TyVar], ThetaType, [TauType], TyCon) -- will panic if not a DataCon -dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _) - = (tyvars, theta_ty, arg_tys, tycon) +dataConSig (Id _ _ _ (AlgConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon) _ _) + = (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) -dataConSig (Id _ _ (TupleConId _ arity) _ _) - = (tyvars, [], tyvar_tys, mkTupleTyCon arity) +dataConSig (Id _ _ _ (TupleConId arity) _ _) + = (tyvars, [], [], [], tyvar_tys, tupleTyCon arity) where tyvars = take arity alphaTyVars tyvar_tys = mkTyVarTys tyvars + +-- dataConRepType returns the type of the representation of a contructor +-- This may differ from the type of the contructor Id itself for two reasons: +-- a) the constructor Id may be overloaded, but the dictionary isn't stored +-- e.g. data Eq a => T a = MkT a a +-- +-- b) the constructor may store an unboxed version of a strict field. +-- +-- Here's an example illustrating both: +-- data Ord a => T a = MkT Int! a +-- Here +-- T :: Ord a => Int -> a -> T a +-- but the rep type is +-- Trep :: Int# -> a -> T a +-- Actually, the unboxed part isn't implemented yet! + +dataConRepType :: Id -> Type +dataConRepType (Id _ _ _ (AlgConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon) _ _) + = mkForAllTys (tyvars++con_tyvars) + (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))) +dataConRepType other_id + = ASSERT( isDataCon other_id ) + idType other_id + dataConFieldLabels :: DataCon -> [FieldLabel] -dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields +dataConFieldLabels (Id _ _ _ (AlgConId _ _ fields _ _ _ _ _ _) _ _) = fields +dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = [] +#ifdef DEBUG +dataConFieldLabels x@(Id _ _ _ idt _ _) = + panic ("dataConFieldLabel: " ++ + (case idt of + LocalId _ -> "l" + SysLocalId _ -> "sl" + PrimitiveId _ -> "p" + ImportedId -> "i" + RecordSelId _ -> "r" + DictSelId _ -> "m" + DefaultMethodId _ -> "d" + DictFunId _ _ -> "di")) +#endif + +dataConStrictMarks :: DataCon -> [StrictnessMark] +dataConStrictMarks (Id _ _ _ (AlgConId _ 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 = zipTyVarEnv tyvars inst_tys \end{code} \begin{code} mkRecordSelId field_label selector_ty - = Id (nameUnique name) + = addStandardIdInfo $ -- Record selectors have a standard unfolding + Id (nameUnique name) + name selector_ty (RecordSelId field_label) NoPragmaInfo @@ -1490,65 +827,12 @@ mkRecordSelId field_label selector_ty name = fieldLabelName field_label recordSelectorFieldLabel :: Id -> FieldLabel -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 +recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl - 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 --} +isRecordSelector (Id _ _ _ (RecordSelId lbl) _ _) = True +isRecordSelector other = False \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} @@ -1568,51 +852,50 @@ 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. +\begin{code} +getIdUnfolding :: Id -> Unfolding -ToDo: what if @DataConId@'s type has a context (haven't thought about it ---WDP)? +getIdUnfolding (Id _ _ _ _ _ info) = unfoldInfo info -Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT -EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the -example above: a, b, and x, y, z], which is enough (in the important -\tr{DsExpr} case). (The middle set of @Ids@ is binders for any -dictionaries, in the even of an overloaded data-constructor---none at -present.) +addIdUnfolding :: Id -> Unfolding -> Id +addIdUnfolding id@(Id u n ty details prag info) unfolding + = Id u n ty details prag (info `addUnfoldInfo` unfolding) +\end{code} + +The inline pragma tells us to be very keen to inline this Id, but it's still +OK not to if optimisation is switched off. \begin{code} -getIdUnfolding :: Id -> UnfoldingDetails - -getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info - -{-LATER: -addIdUnfolding :: Id -> UnfoldingDetails -> Id -addIdUnfolding id@(Id u ty info details) unfold_details - = ASSERT( - case (isLocallyDefined id, unfold_details) of - (_, NoUnfoldingDetails) -> True - (True, IWantToBeINLINEd _) -> True - (False, IWantToBeINLINEd _) -> False -- v bad - (False, _) -> True - _ -> False -- v bad - ) - Id u ty (info `addInfo_UF` unfold_details) details --} +getInlinePragma :: Id -> PragmaInfo +getInlinePragma (Id _ _ _ _ prag _) = prag + +idWantsToBeINLINEd :: Id -> Bool + +idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True +idWantsToBeINLINEd (Id _ _ _ _ IMustBeINLINEd _) = True +idWantsToBeINLINEd _ = False + +idMustNotBeINLINEd (Id _ _ _ _ IMustNotBeINLINEd _) = True +idMustNotBeINLINEd _ = False + +idMustBeINLINEd (Id _ _ _ _ IMustBeINLINEd _) = True +idMustBeINLINEd _ = False + +addInlinePragma :: Id -> Id +addInlinePragma (Id u sn ty details _ info) + = Id u sn ty details IWantToBeINLINEd info + +nukeNoInlinePragma :: Id -> Id +nukeNoInlinePragma id@(Id u sn ty details IMustNotBeINLINEd info) + = Id u sn ty details NoPragmaInfo info +nukeNoInlinePragma id@(Id u sn ty details _ info) = id -- Otherwise no-op + +addNoInlinePragma :: Id -> Id +addNoInlinePragma id@(Id u sn ty details _ info) + = Id u sn ty details IMustNotBeINLINEd info \end{code} -In generating selector functions (take a dictionary, give back one -component...), we need to what out for the nothing-to-select cases (in -which case the ``selector'' is just an identity function): -\begin{verbatim} -class Eq a => Foo a { } # the superdict selector for "Eq" -class Foo a { op :: Complex b => c -> b -> a } - # the method selector for "op"; - # note local polymorphism... -\end{verbatim} %************************************************************************ %* * @@ -1622,53 +905,51 @@ class Foo a { op :: Complex b => c -> b -> a } \begin{code} getIdDemandInfo :: Id -> DemandInfo -getIdDemandInfo (Id _ _ _ _ info) = getInfo info +getIdDemandInfo (Id _ _ _ _ _ info) = demandInfo 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 `addDemandInfo` demand_info) \end{code} \begin{code} getIdUpdateInfo :: Id -> UpdateInfo -getIdUpdateInfo (Id _ _ _ _ info) = getInfo info +getIdUpdateInfo (Id _ _ _ _ _ info) = updateInfo 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 `addUpdateInfo` 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) = argUsageInfo 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 `addArgusageInfo` 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) = fbTypeInfo 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 `addFBTypeInfo` upd_info) details -} \end{code} \begin{code} -{- LATER: -getIdSpecialisation :: Id -> SpecEnv -getIdSpecialisation (Id _ _ _ _ info) = getInfo info +getIdSpecialisation :: Id -> IdSpecEnv +getIdSpecialisation (Id _ _ _ _ _ info) = specInfo info -addIdSpecialisation :: Id -> SpecEnv -> Id -addIdSpecialisation (Id u ty details prags info) spec_info - = Id u ty details prags (info `addInfo` spec_info) --} +setIdSpecialisation :: Id -> IdSpecEnv -> Id +setIdSpecialisation (Id u n ty details prags info) spec_info + = Id u n ty details prags (info `setSpecInfo` spec_info) \end{code} Strictness: we snaffle the info out of the IdInfo. @@ -1676,12 +957,11 @@ Strictness: we snaffle the info out of the IdInfo. \begin{code} getIdStrictness :: Id -> StrictnessInfo -getIdStrictness (Id _ _ _ _ info) = getInfo info +getIdStrictness (Id _ _ _ _ _ info) = strictnessInfo 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 `addStrictnessInfo` strict_info) \end{code} %************************************************************************ @@ -1693,50 +973,21 @@ 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 _ _ _ _ _) = compare u1 u2 -- short and very sweet \end{code} \begin{code} -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 `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` 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 } -\end{code} - -@cmpId_withSpecDataCon@ ensures that any spectys are taken into -account when comparing two data constructors. We need to do this -because a specialised data constructor has the same Unique as its -unspecialised counterpart. - -\begin{code} -cmpId_withSpecDataCon :: Id -> Id -> TAG_ - -cmpId_withSpecDataCon id1 id2 - | eq_ids && isDataCon id1 && isDataCon id2 - = cmpEqDataCon id1 id2 - - | otherwise - = cmp_ids - where - cmp_ids = cmpId id1 id2 - eq_ids = case cmp_ids of { EQ_ -> True; other -> False } - -cmpEqDataCon (Id _ _ (SpecId _ mtys1 _) _ _) (Id _ _ (SpecId _ mtys2 _) _ _) - = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2" - -cmpEqDataCon _ (Id _ _ (SpecId _ _ _) _ _) = LT_ -cmpEqDataCon (Id _ _ (SpecId _ _ _) _ _) _ = GT_ -cmpEqDataCon _ _ = EQ_ + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpId a b \end{code} %************************************************************************ @@ -1747,148 +998,37 @@ cmpEqDataCon _ _ = EQ_ \begin{code} instance Outputable ty => Outputable (GenId ty) where - ppr sty id = pprId sty id - --- and a SPECIALIZEd one: -instance Outputable {-Id, i.e.:-}(GenId Type) where - ppr sty id = pprId sty id - -showId :: PprStyle -> Id -> String -showId sty id = ppShow 80 (pprId sty id) - --- [used below] --- for DictFuns (instances) and const methods (instance code bits we --- can call directly): exported (a) if *either* the class or --- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both* --- class and tycon are from PreludeCore [non-std, but convenient] --- *and* the thing was defined in this module. - -instance_export_flag :: Class -> Type -> Bool -> ExportFlag - -instance_export_flag clas inst_ty from_here - = panic "Id:instance_export_flag" -{-LATER - = if instanceIsExported clas inst_ty from_here - then ExportAll - else NotExported --} + ppr id = pprId id + +showId :: Id -> String +showId id = showSDoc (pprId id) \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 -> ppr other_sty occur_name - PprForUser -> ppr other_sty 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 = getOccName id `appendRdr` - (if not (isSysLocalId id) - then SLIT("") - else SLIT(".") _APPEND_ (showUnique (idUnique 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 (idUnique 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 :: Outputable ty => GenId ty -> SDoc +pprId (Id u n _ _ prags _) + = hcat [ppr n, pp_prags] + where + pp_prags | opt_PprStyle_All = case prags of + IMustNotBeINLINEd -> text "{n}" + IWantToBeINLINEd -> text "{i}" + IMustBeINLINEd -> text "{I}" + other -> empty + | otherwise = empty + + -- WDP 96/05/06: We can re-elaborate this as we go along... \end{code} \begin{code} -idUnique (Id u _ _ _ _) = u +idUnique (Id u _ _ _ _ _) = u instance Uniquable (GenId ty) where uniqueOf = idUnique instance NamedThing (GenId ty) where - getName this_id@(Id u _ details _ _) - = get details - where - get (LocalId n _) = n - get (SysLocalId n _) = n - get (SpecPragmaId n _ _)= n - get (ImportedId n) = n - get (PreludeId n) = n - get (TopLevId n) = n - get (InstId n _) = n - get (DataConId n _ _ _ _ _ _ _) = n - get (TupleConId n _) = n - get (RecordSelId l) = getName l --- get _ = pprPanic "Id.Id.NamedThing.getName:" (pprId PprDebug this_id) - -{- LATER: - get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ??? - (mod, _) -> (mod, getClassOpString op) - - 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 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 --} + getName this_id@(Id u n _ details _ _) = n \end{code} Note: The code generator doesn't carry a @UniqueSupply@, so it uses @@ -1915,15 +1055,17 @@ 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 lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a +elemIdEnv :: Id -> IdEnv a -> Bool \end{code} \begin{code} +elemIdEnv = elemUFM addOneToIdEnv = addToUFM combineIdEnvs = plusUFM_C delManyFromIdEnv = delListFromUFM @@ -1935,18 +1077,28 @@ mkIdEnv = listToUFM nullIdEnv = emptyUFM rngIdEnv = eltsUFM unitIdEnv = unitUFM +isNullIdEnv = isNullUFM growIdEnvList env pairs = plusUFM env (listToUFM pairs) -isNullIdEnv env = sizeUFM env == 0 lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx } +lookupIdSubst :: IdEnv Id -> Id -> Id +lookupIdSubst env id = case lookupIdEnv env id of + Just id' -> id' -- Return original if + Nothing -> id -- it isn't in subst + -- 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}