X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=5704027260659093f84bb732fe0fb539ed5d58e5;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=971855ff2d2478fef5e1b67e68a3d4b71e174ec9;hpb=68a1f0233996ed79824d11d946e9801473f6946c;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 971855f..5704027 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -1,14 +1,14 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[Id]{@Ids@: Value and constructor identifiers} \begin{code} #include "HsVersions.h" -module Id ( - Id, -- abstract - IdInfo, -- re-exporting +module Id {- ( + GenId, Id(..), -- Abstract + StrictnessMark(..), -- An enumaration ConTag(..), DictVar(..), DictFun(..), DataCon(..), -- CONSTRUCTION @@ -20,44 +20,40 @@ module Id ( mkImported, mkPreludeId, mkDataCon, mkTupleCon, mkIdWithNewUniq, - mkClassOpId, mkSuperDictSelId, mkDefaultMethodId, - mkConstMethodId, mkInstId, -#ifdef DPH - mkProcessorCon, - mkPodId, -#endif {- Data Parallel Haskell -} + mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId, + mkConstMethodId, getConstMethodId, updateIdType, - mkId, mkDictFunId, + mkId, mkDictFunId, mkInstId, mkWorkerId, localiseId, -- DESTRUCTION - getIdUniType, - getInstNamePieces, getIdInfo, replaceIdInfo, - getIdKind, getInstIdModule, + idType, + getIdInfo, replaceIdInfo, + getPragmaInfo, + idPrimRep, getInstIdModule, getMentionedTyConsAndClassesFromId, - getDataConTag, - getDataConSig, getInstantiatedDataConSig, - getDataConTyCon, -- UNUSED: getDataConFamily, -#ifdef USE_SEMANTIQUE_STRANAL - getDataConDeps, -#endif + + dataConTag, dataConStrictMarks, + dataConSig, dataConRawArgTys, dataConArgTys, + dataConTyCon, dataConArity, + dataConFieldLabels, + + recordSelectorFieldLabel, -- PREDICATES - isDataCon, isTupleCon, isNullaryDataCon, + isDataCon, isTupleCon, + isNullaryDataCon, isSpecId_maybe, isSpecPragmaId_maybe, toplevelishId, externallyVisibleId, isTopLevId, isWorkerId, isWrapperId, isImportedId, isSysLocalId, isBottomingId, - isClassOpId, isDefaultMethodId_maybe, isSuperDictSelId_maybe, - isDictFunId, isInstId_maybe, isConstMethodId_maybe, -#ifdef DPH - isInventedTopLevId, - isProcessorCon, -#endif {- Data Parallel Haskell -} - eqId, cmpId, + isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe, + isDictFunId, +--??? isInstId_maybe, + isConstMethodId_maybe, cmpId_withSpecDataCon, myWrapperMaybe, whatsMentionedInId, @@ -70,11 +66,11 @@ module Id ( -- not exported: apply_to_Id, -- please don't use this, generally -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc) - getIdArity, getDataConArity, addIdArity, + getIdArity, addIdArity, getIdDemandInfo, addIdDemandInfo, getIdSpecialisation, addIdSpecialisation, getIdStrictness, addIdStrictness, - getIdUnfolding, addIdUnfolding, -- UNUSED? clearIdUnfolding, + getIdUnfolding, addIdUnfolding, getIdUpdateInfo, addIdUpdateInfo, getIdArgUsageInfo, addIdArgUsageInfo, getIdFBTypeInfo, addIdFBTypeInfo, @@ -86,100 +82,110 @@ module Id ( showId, pprIdInUnfolding, - -- and to make the interface self-sufficient... - Class, ClassOp, GlobalSwitch, Inst, Maybe, Name, - FullName, PprStyle, PrettyRep, - PrimKind, SrcLoc, Pretty(..), Subst, UnfoldingDetails, - TyCon, TyVar, TyVarTemplate, TauType(..), UniType, Unique, - UniqueSupply, Arity(..), ThetaType(..), - TypeEnv(..), UniqFM, InstTemplate, Bag, - SpecEnv, nullSpecEnv, SpecInfo, - - -- and to make sure pragmas work... - IdDetails -- from this module, abstract - IF_ATTACK_PRAGMAS(COMMA getMentionedTyConsAndClassesFromUniType) - IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) - IF_ATTACK_PRAGMAS(COMMA getInfo_UF) - -#ifndef __GLASGOW_HASKELL__ - , TAG_ -#endif - ) where + nmbrId, -IMPORT_Trace -- ToDo: rm (debugging only) + -- "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, -import AbsPrel ( PrimOp, PrimKind, mkFunTy, nilDataCon, pRELUDE_BUILTIN - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) -#ifdef DPH - , mkPodNTy, mkPodizedPodNTy -#endif {- Data Parallel Haskell -} - ) + -- and to make the interface self-sufficient... + GenIdSet(..), IdSet(..) + )-} where + +IMP_Ubiq() +IMPORT_DELOOPER(IdLoop) -- for paranoia checking +IMPORT_DELOOPER(TyLoop) -- for paranoia checking -import AbsUniType import Bag -import CLabelInfo ( identToC, cSEP ) -import CmdLineOpts ( GlobalSwitch(..) ) -import IdEnv -- ( nullIdEnv, IdEnv ) -import IdInfo -- piles of it -import Inst -- lots of things -import Maybes ( maybeToBool, Maybe(..) ) -import Name ( Name(..) ) -import NameTypes -import Outputable -import Pretty -- for pretty-printing -import SrcLoc -import Subst ( applySubstToTy ) -- PRETTY GRIMY TO LOOK IN HERE -import PlainCore -import PrelFuns ( pcGenerateTupleSpecs ) -- PRETTY GRIMY TO LOOK IN HERE +import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp ) +import CStrings ( identToC, cSEP ) +import IdInfo +import Maybes ( maybeToBool ) +import Name ( appendRdr, nameUnique, mkLocalName, isLocalName, + isLocallyDefinedName, isPreludeDefinedName, + mkTupleDataConName, mkCompoundName, mkCompoundName2, + isLexSym, isLexSpecialSym, getLocalName, + isLocallyDefined, isPreludeDefined, changeUnique, + getOccName, moduleNamePair, origName, nameOf, + isExported, ExportFlag(..), + RdrName(..), Name + ) +import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} ) +import PragmaInfo ( PragmaInfo(..) ) +import PprEnv -- ( NmbrM(..), NmbrEnv(..) ) +import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix, + nmbrType, nmbrTyVar, + 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 TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) ) import UniqFM -import UniqSet -import Unique -import Util -#ifdef DPH -IMPORT_Trace -import PodizeCore ( podizeTemplateExpr ) -import PodInfoTree ( infoTypeNumToMask ) -#endif {- Data Parallel Haskell -} +import UniqSet -- practically all of it +import Unique ( getBuiltinUniques, pprUnique, showUnique, + incrUnique, + Unique{-instance Ord3-} + ) +import Util ( mapAccumL, nOfThem, zipEqual, + panic, panic#, pprPanic, assertPanic + ) \end{code} Here are the @Id@ and @IdDetails@ datatypes; also see the notes that follow. Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a -@UniType@, and an @IdInfo@ (non-essential info about it, e.g., +@Type@, and an @IdInfo@ (non-essential info about it, e.g., strictness). The essential info about different kinds of @Ids@ is in its @IdDetails@. ToDo: possibly cache other stuff in the single-constructor @Id@ type. \begin{code} -data Id = Id Unique -- key for fast comparison - UniType -- Id's type; used all the time; - IdInfo -- non-essential info about this Id; - IdDetails -- stuff about individual kinds of Ids. +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 + +data StrictnessMark = MarkedStrict | NotMarkedStrict data IdDetails ---------------- Local values - = LocalId ShortName -- mentioned by the user - Bool -- True <=> no free type vars + = LocalId Bool -- Local name; mentioned by the user + -- True <=> no free type vars - | SysLocalId ShortName -- made up by the compiler - Bool -- as for LocalId + | SysLocalId Bool -- Local name; made up by the compiler + -- as for LocalId - | SpecPragmaId ShortName -- introduced by the compiler - (Maybe SpecInfo)-- for explicit specid in pragma - Bool -- as for LocalId + | SpecPragmaId -- Local name; introduced by the compiler + (Maybe Id) -- for explicit specid in pragma + Bool -- as for LocalId ---------------- Global values - | ImportedId FullName -- Id imported from an interface + | ImportedId -- Global name (Imported or Implicit); Id imported from an interface - | PreludeId FullName -- things < Prelude that compiler "knows" about + | PreludeId -- Global name (Builtin); Builtin prelude Ids - | TopLevId FullName -- Top-level in the orig source pgm + | TopLevId -- Global name (LocalDef); Top-level in the orig source pgm -- (not moved there by transformations). -- a TopLevId's type may contain free type variables, if @@ -187,24 +193,18 @@ data IdDetails ---------------- Data constructors - | DataConId FullName - ConTag - -- cached pieces of the type: - [TyVarTemplate] [(Class,UniType)] [UniType] TyCon - -- the type is: - -- forall tyvars . theta_ty => - -- unitype_1 -> ... -> unitype_n -> tycon tyvars - -- - -- "type ThetaType = [(Class, UniType)]" + | DataConId ConTag + [StrictnessMark] -- Strict args; length = arity + [FieldLabel] -- Field labels for this constructor - -- The [TyVarTemplate] is in the same order as the args of the - -- TyCon for the constructor + [TyVar] [(Class,Type)] [Type] TyCon + -- the type is: + -- forall tyvars . theta_ty => + -- unitype_1 -> ... -> unitype_n -> tycon tyvars | TupleConId Int -- Its arity -#ifdef DPH - | ProcessorCon Int -- Its arity -#endif {- Data Parallel Haskell -} + | RecordSelId FieldLabel ---------------- Things to do with overloading @@ -212,22 +212,61 @@ data IdDetails Class -- The class (input dict) Class -- The superclass (result dict) - | ClassOpId Class -- An overloaded class operation, with + | 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 ClassOpId has all the info about its + -- NB: The IdInfo for a MethodSelId has all the info about its -- related "constant method Ids", which are just -- specialisations of this general one. | DefaultMethodId -- Default method for a particular class op - Class -- same class, info as ClassOpId + 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, + -- 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. + (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 + (Maybe Module) -- module where instance came from; Nothing => Prelude + + | InstId -- 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 +type DictVar = Id +type DictFun = Id +type DataCon = Id \end{code} DictFunIds are generated from instance decls. @@ -251,21 +290,10 @@ automatically generated specialisations of the instance decl: \end{verbatim} generates \begin{verbatim} - dfun.Foo.[Int] = ... + dfun.Foo.[Int] = ... \end{verbatim} The type variables in the name are irrelevant; we print them as stars. -\begin{code} - | DictFunId Class -- A DictFun is uniquely identified - UniType -- 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 - FAST_STRING -- module where instance came from -\end{code} Constant method ids are generated from instance decls where there is no context; that is, no dictionaries are needed to @@ -293,48 +321,12 @@ We get the constant method So a constant method is identified by a class/op/type triple. The type variables in the type are irrelevant. -\begin{code} - | ConstMethodId -- A method which depends only on the type of the - -- instance, and not on any further dictionaries etc. - Class -- Uniquely identified by: - UniType -- (class, type, classop) triple - ClassOp - Bool -- True <=> from an instance decl in this mod - FAST_STRING -- module where instance came from - - | InstId Inst -- An instance of a dictionary, class operation, - -- or overloaded value - - | SpecId -- A specialisation of another Id - Id -- Id of which this is a specialisation - [Maybe UniType] -- 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 UniType" dudes). - - | WorkerId -- A "worker" for some other Id - Id -- Id for which this is a worker - -#ifdef DPH - | PodId Int -- The dimension of the PODs context - Int -- Which specialisation of InfoType is - -- bind. ToDo(hilly): Int is a little messy - -- and has a restricted range---change. - Id -- One of the aboves Ids. -#endif {- Data Parallel Haskell -} - -type ConTag = Int -type DictVar = Id -type DictFun = Id -type DataCon = Id -\end{code} 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} @@ -344,7 +336,7 @@ names... etc) in a known systematic way. [A BIT DATED [WDP]] The @Id@ datatype describes {\em values}. The basic things we want to -know: (1)~a value's {\em type} (@getIdUniType@ is a very common +know: (1)~a value's {\em type} (@idType@ is a very common operation in the compiler); and (2)~what ``flavour'' of value it might be---for example, it can be terribly useful to know that a value is a class method. @@ -353,7 +345,7 @@ class method. %---------------------------------------------------------------------- \item[@DataConId@:] For the data constructors declared by a @data@ declaration. Their type is kept in {\em two} forms---as a regular -@UniType@ (in the usual place), and also in its constituent pieces (in +@Type@ (in the usual place), and also in its constituent pieces (in the ``details''). We are frequently interested in those pieces. %---------------------------------------------------------------------- @@ -371,7 +363,7 @@ their @IdInfo@). %---------------------------------------------------------------------- \item[@TopLevId@:] These are values defined at the top-level in this module; i.e., those which {\em might} be exported (hence, a -@FullName@). It does {\em not} include those which are moved to the +@Name@). It does {\em not} include those which are moved to the top-level through program transformations. We also guarantee that @TopLevIds@ will {\em stay} at top-level. @@ -387,7 +379,7 @@ what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change} between (1) and (2), you're sunk! %---------------------------------------------------------------------- -\item[@ClassOpId@:] A selector from a dictionary; it may select either +\item[@MethodSelId@:] A selector from a dictionary; it may select either a method or a dictionary for one of the class's superclasses. %---------------------------------------------------------------------- @@ -437,7 +429,7 @@ Further remarks: \item @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@, -@ClassOpIds@, @DictFunIds@, and @DefaultMethodIds@ have the following +@MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following properties: \begin{itemize} \item @@ -452,7 +444,6 @@ Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above properties, but they may not. \end{enumerate} - %************************************************************************ %* * \subsection[Id-general-funs]{General @Id@-related functions} @@ -460,238 +451,184 @@ properties, but they may not. %************************************************************************ \begin{code} -isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _)) = True -isDataCon (Id _ _ _ (TupleConId _)) = True -isDataCon (Id _ _ _ (SpecId unspec _ _)) = isDataCon unspec -#ifdef DPH -isDataCon (ProcessorCon _ _) = True -isDataCon (PodId _ _ id ) = isDataCon id -#endif {- Data Parallel Haskell -} -isDataCon other = False - -isTupleCon (Id _ _ _ (TupleConId _)) = True -isTupleCon (Id _ _ _ (SpecId unspec _ _)) = isTupleCon unspec -#ifdef DPH -isTupleCon (PodId _ _ id) = isTupleCon id -#endif {- Data Parallel Haskell -} -isTupleCon other = False - -isNullaryDataCon data_con - = isDataCon data_con - && (case arityMaybe (getIdArity data_con) of - Just a -> a == 0 - _ -> panic "isNullaryDataCon") - -isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _)) +unsafeGenId2Id :: GenId ty -> Id +unsafeGenId2Id (Id u n ty d p i) = Id u n (panic "unsafeGenId2Id:ty") d p i + +isDataCon id = is_data (unsafeGenId2Id id) + where + is_data (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True + is_data (Id _ _ _ (TupleConId _) _ _) = True + is_data (Id _ _ _ (SpecId unspec _ _) _ _) = is_data unspec + is_data 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 _ specinfo _)) - = Just specinfo +isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId specid _) _ _) + = Just specid isSpecPragmaId_maybe other_id = Nothing - -#ifdef DPH -isProcessorCon (ProcessorCon _ _) = True -isProcessorCon (PodId _ _ id) = isProcessorCon id -isProcessorCon other = False -#endif {- Data Parallel Haskell -} +-} \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 (ImportedId _) = True - chk (PreludeId _) = True - chk (TopLevId _) = True -- NB: see notes - chk (SuperDictSelId _ _) = True - chk (ClassOpId _ _) = 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 -#ifdef DPH - chk (ProcessorCon _ _) = True - chk (PodId _ _ id) = toplevelishId id -#endif {- Data Parallel Haskell -} - -idHasNoFreeTyVars (Id _ _ info details) + chk (DataConId _ _ _ _ _ _ _) = 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 details where - chk (DataConId _ _ _ _ _ _) = True - chk (TupleConId _) = True - chk (ImportedId _) = True - chk (PreludeId _) = True - chk (TopLevId _) = True - chk (SuperDictSelId _ _) = True - chk (ClassOpId _ _) = True - chk (DefaultMethodId _ _ _) = True - chk (DictFunId _ _ _ _) = True - chk (ConstMethodId _ _ _ _ _) = True - chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr - chk (InstId _) = False -- these are local + chk (DataConId _ _ _ _ _ _ _) = 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 (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 -#ifdef DPH - chk (ProcessorCon _ _) = True - chk (PodId _ _ id) = idHasNoFreeTyVars id -#endif {- Data Parallel Haskell -} + chk (InstId no_free_tvs) = no_free_tvs + chk (LocalId no_free_tvs) = no_free_tvs + chk (SysLocalId no_free_tvs) = no_free_tvs + chk (SpecPragmaId _ no_free_tvs) = no_free_tvs \end{code} \begin{code} -isTopLevId (Id _ _ _ (TopLevId _)) = True -#ifdef DPH -isTopLevId (PodId _ _ id) = isTopLevId id -#endif {- Data Parallel Haskell -} -isTopLevId other = False - --- an "invented" one is a top-level Id, must be globally visible, etc., --- but it's slightly different in that it was "conjured up". --- This handles workers fine, but may need refinement for other --- conjured-up things (e.g., specializations) --- NB: Only used in DPH now (93/08/20) - -#ifdef DPH -ToDo: DPH -isInventedTopLevId (TopLevId _ n _ _) = isInventedFullName n -isInventedTopLevId (SpecId _ _ _) = True -isInventedTopLevId (WorkerId _) = True -isInventedTopLevId (PodId _ _ id) = isInventedTopLevId id -isInventedTopLevId other = False -#endif {- Data Parallel Haskell -} - -isImportedId (Id _ _ _ (ImportedId _)) = True -#ifdef DPH -isImportedId (PodId _ _ id) = isImportedId id -#endif {- Data Parallel Haskell -} -isImportedId other = False - -isBottomingId (Id _ _ info _) = bottomIsGuaranteed (getInfo info) -#ifdef DPH -isBottomingId (PodId _ _ id) = isBottomingId id -#endif {- Data Parallel Haskell -} ---isBottomingId other = False - -isSysLocalId (Id _ _ _ (SysLocalId _ _)) = True -#ifdef DPH -isSysLocalId (PodId _ _ id) = isSysLocalId id -#endif {- Data Parallel Haskell -} -isSysLocalId other = False - -isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _ _)) = True -#ifdef DPH -isSpecPragmaId (PodId _ _ id) = isSpecPragmaId id -#endif {- Data Parallel Haskell -} -isSpecPragmaId other = False - -isClassOpId (Id _ _ _ (ClassOpId _ _)) = True -isClassOpId _ = False - -isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err)) = Just (cls, clsop, err) -#ifdef DPH -isDefaultMethodId_maybe (PodId _ _ id) = isDefaultMethodId_maybe id -#endif {- Data Parallel Haskell -} -isDefaultMethodId_maybe other = Nothing - -isDictFunId (Id _ _ _ (DictFunId _ _ _ _)) = True -#ifdef DPH -isDictFunId (PodId _ _ id) = isDictFunId id -#endif {- Data Parallel Haskell -} -isDictFunId other = False - -isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _ _)) = Just (cls, ty, clsop) -#ifdef DPH -isConstMethodId_maybe (PodId _ _ id) = isConstMethodId_maybe id -#endif {- Data Parallel Haskell -} -isConstMethodId_maybe other = Nothing - -isInstId_maybe (Id _ _ _ (InstId inst)) = Just inst -#ifdef DPH -isInstId_maybe (PodId _ _ id) = isInstId_maybe id -#endif {- Data Parallel Haskell -} -isInstId_maybe other_id = Nothing - -isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc)) = Just (c, sc) -#ifdef DPH -isSuperDictSelId_maybe (PodId _ _ id) = isSuperDictSelId_maybe id -#endif {- Data Parallel Haskell -} -isSuperDictSelId_maybe other_id = Nothing - -isWorkerId (Id _ _ _ (WorkerId _)) = True -#ifdef DPH -isWorkerId (PodId _ _ id) = isWorkerId id -#endif {- Data Parallel Haskell -} -isWorkerId other = False +isTopLevId (Id _ _ _ TopLevId _ _) = True +isTopLevId other = False + +isImportedId (Id _ _ _ ImportedId _ _) = True +isImportedId other = False + +isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (getInfo info) + +isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True +isSysLocalId other = False + +isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True +isSpecPragmaId other = False + +isMethodSelId (Id _ _ _ (MethodSelId _ _) _ _) = True +isMethodSelId _ = False + +isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True +isDefaultMethodId other = False + +isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _) + = Just (cls, clsop, err) +isDefaultMethodId_maybe other = Nothing +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 = getIdUniType v + v_ty = idType v in -- local vars first: if v `elementOfUniqSet` in_scopes then - pprUnique (getTheUnique v) + 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 (getDataConArity v)) + ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v)) -- ones to think about: else let - (Id _ _ _ v_details) = v + (Id _ _ _ v_details _ _) = v in case v_details of -- these ones must have been exported by their original module - ImportedId _ -> pp_full_name - PreludeId _ -> pp_full_name + ImportedId -> pp_full_name + PreludeId -> pp_full_name -- these ones' exportedness checked later... - TopLevId _ -> pp_full_name - DataConId _ _ _ _ _ _ -> pp_full_name + 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] - ClassOpId c o + 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 _ _ + DictFunId c t _ -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t] - ConstMethodId c t o _ _ + ConstMethodId c t o _ -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t] -- specialisations and workers @@ -716,23 +653,23 @@ pprIdInUnfolding in_scopes v pp_full_name = let - (m_str, n_str) = getOrigName v + (m_str, n_str) = moduleNamePair v pp_n = - if isAvarop n_str || isAconop n_str then + if isLexSym n_str && not (isLexSpecialSym n_str) then ppBesides [ppLparen, ppPStr n_str, ppRparen] else ppPStr n_str in - if fromPreludeCore v then + if isPreludeDefined v then pp_n else ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n] pp_class :: Class -> Pretty pp_class_op :: ClassOp -> Pretty - pp_type :: UniType -> Pretty - pp_ty_maybe :: Maybe UniType -> 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 @@ -741,6 +678,7 @@ pprIdInUnfolding in_scopes v 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 @@ -749,6 +687,7 @@ 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 @@ -756,10 +695,10 @@ whatsMentionedInId whatsMentionedInId in_scopes v = let - v_ty = getIdUniType v + v_ty = idType v (tycons, clss) - = getMentionedTyConsAndClassesFromUniType v_ty + = getMentionedTyConsAndClassesFromType v_ty result0 id_bag = (id_bag, tycons, clss) @@ -775,7 +714,7 @@ whatsMentionedInId in_scopes v -- ones to think about: else let - (Id _ _ _ v_details) = v + (Id _ _ _ v_details _ _) = v in case v_details of -- specialisations and workers @@ -792,14 +731,17 @@ whatsMentionedInId in_scopes v 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 +myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper +myWrapperMaybe other_id = Nothing +-} \end{code} \begin{code} @@ -808,11 +750,14 @@ 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)) +unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper) _ _) = class_thing wrapper where -- "class thing": If we're going to use this worker Id in @@ -821,33 +766,30 @@ unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper)) -- 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 _ _ _ (ClassOpId _ _)) = True - class_thing (Id _ _ _ (DefaultMethodId _ _ _)) = True + 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 _ _)) _ _)) +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) - = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) ( - naughty_DictFunId dfun - --) + = naughty_DictFunId dfun -unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) - = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) ( - naughty_DictFunId dfun -- similar deal... - --) +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 _ _) +naughty_DictFunId (DictFunId _ _ _) = panic "False" -- came from outside; must be OK +naughty_DictFunId (DictFunId _ ty _) = not (isGroundTy ty) +-} \end{code} @externallyVisibleId@: is it true that another module might be @@ -861,7 +803,7 @@ compiling the prelude, the compiler may not recognise that as true. \begin{code} externallyVisibleId :: Id -> Bool -externallyVisibleId id@(Id _ _ _ details) +externallyVisibleId id@(Id _ _ _ details _ _) = if isLocallyDefined id then toplevelishId id && isExported id && not (weird_datacon details) else @@ -878,8 +820,10 @@ externallyVisibleId id@(Id _ _ _ details) -- of WeirdLocalType; but we need to know this when asked if -- "Mumble" is externally visible... - weird_datacon (DataConId _ _ _ _ _ tycon) +{- LATER: if at all: + weird_datacon (DataConId _ _ _ _ _ _ tycon) = maybeToBool (maybePurelyLocalTyCon tycon) +-} weird_datacon not_a_datacon_therefore_not_weird = False weird_tuplecon (TupleConId arity) @@ -890,61 +834,51 @@ externallyVisibleId id@(Id _ _ _ details) \begin{code} idWantsToBeINLINEd :: Id -> Bool -idWantsToBeINLINEd id - = case (getIdUnfolding id) of - IWantToBeINLINEd _ -> True - _ -> False +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 fn ty info TopLevId) + = Just (Id u (unlocaliseFullName fn) ty info TopLevId) -unlocaliseId mod (Id u ty info (LocalId sn no_ftvs)) +unlocaliseId mod (Id u sn ty info (LocalId no_ftvs)) = --false?: ASSERT(no_ftvs) let full_name = unlocaliseShortName mod u sn in - Just (Id u ty info (TopLevId full_name)) + Just (Id u full_name ty info TopLevId) -unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs)) +unlocaliseId mod (Id u sn ty info (SysLocalId no_ftvs)) = --false?: on PreludeGlaST: ASSERT(no_ftvs) let full_name = unlocaliseShortName mod u sn in - Just (Id u ty info (TopLevId full_name)) + Just (Id u full_name ty info TopLevId) -unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs)) +unlocaliseId mod (Id u n ty info (SpecId unspec ty_maybes no_ftvs)) = case unlocalise_parent mod u unspec of Nothing -> Nothing - Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs)) + Just xx -> Just (Id u n ty info (SpecId xx ty_maybes no_ftvs)) -unlocaliseId mod (Id u ty info (WorkerId unwrkr)) +unlocaliseId mod (Id u n ty info (WorkerId unwrkr)) = case unlocalise_parent mod u unwrkr of Nothing -> Nothing - Just xx -> Just (Id u ty info (WorkerId xx)) + Just xx -> Just (Id u n ty info (WorkerId xx)) -unlocaliseId mod (Id u ty info (InstId inst)) - = Just (Id u ty info (TopLevId full_name)) +unlocaliseId mod (Id u name ty info (InstId no_ftvs)) + = Just (Id u full_name ty info TopLevId) -- type might be wrong, but it hardly matters -- at this stage (just before printing C) ToDo where - name = let (bit1:bits) = getInstNamePieces True inst in - _CONCAT_ (bit1 : [ _CONS_ '.' b | b <- bits ]) - - full_name = mkFullName mod (mod _APPEND_ name) InventedInThisModule ExportAll mkGeneratedSrcLoc - -#ifdef DPH -unlocaliseId mod (PodId dim ity id) - = case (unlocaliseId mod id) of - Just id' -> Just (PodId dim ity id') - Nothing -> Nothing -#endif {- Data Parallel Haskell -} + name = getLocalName name + full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc unlocaliseId mod other_id = Nothing @@ -952,22 +886,23 @@ unlocaliseId mod other_id = Nothing -- we have to be Very Careful for workers/specs of -- local functions! -unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs)) +unlocalise_parent mod uniq (Id _ sn ty info (LocalId no_ftvs)) = --false?: ASSERT(no_ftvs) let full_name = unlocaliseShortName mod uniq sn in - Just (Id uniq ty info (TopLevId full_name)) + Just (Id uniq full_name ty info TopLevId) -unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs)) +unlocalise_parent mod uniq (Id _ sn ty info (SysLocalId no_ftvs)) = --false?: ASSERT(no_ftvs) let full_name = unlocaliseShortName mod uniq sn in - Just (Id uniq ty info (TopLevId full_name)) + Just (Id uniq full_name ty info TopLevId) unlocalise_parent mod uniq other_id = unlocaliseId mod other_id -- we're OK otherwise +-} \end{code} CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@: @@ -978,9 +913,11 @@ 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 u ty info details) +applyTypeEnvToId type_env id@(Id _ _ ty _ _ _) | idHasNoFreeTyVars id = id | otherwise @@ -990,26 +927,21 @@ applyTypeEnvToId type_env id@(Id u ty info details) \end{code} \begin{code} -apply_to_Id :: (UniType -> UniType) - -> Id - -> Id +apply_to_Id :: (Type -> Type) -> Id -> Id -apply_to_Id ty_fn (Id u ty info details) - = Id u (ty_fn ty) (apply_to_IdInfo ty_fn info) (apply_to_details details) +apply_to_Id ty_fn (Id u n ty details prag info) + = let + new_ty = ty_fn ty + in + Id u n new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info) where - apply_to_details (InstId inst) - = let - new_inst = apply_to_Inst ty_fn inst - in - InstId new_inst - 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_ftvs - -- ToDo: recalc no_ftvs???? + 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) @@ -1020,11 +952,6 @@ apply_to_Id ty_fn (Id u ty info details) in WorkerId new_unwrkr -#ifdef DPH - apply_to_details (PodId d ity id ) - = PodId d ity (apply_to_Id ty_fn id) -#endif {- Data Parallel Haskell -} - apply_to_details other = other \end{code} @@ -1035,24 +962,25 @@ 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) +applySubstToId subst id@(Id u n ty info details) -- *cannot* have a "idHasNoFreeTyVars" get-out clause -- because, in the typechecker, we are still -- *concocting* the types. = case (applySubstToTy subst ty) of { (s2, new_ty) -> case (applySubstToIdInfo s2 info) of { (s3, new_info) -> case (apply_to_details s3 new_ty details) of { (s4, new_details) -> - (s4, Id u new_ty new_info new_details) }}} + (s4, Id u n new_ty new_info new_details) }}} where - apply_to_details subst _ (InstId inst) + apply_to_details subst _ (InstId inst no_ftvs) = case (applySubstToInst subst inst) of { (s2, new_inst) -> - (s2, InstId 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) -> + 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 @@ -1063,133 +991,10 @@ applySubstToId subst id@(Id u ty info details) apply_to_details subst _ (WorkerId unwrkr) = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) -> - (s2, WorkerId new_unwrkr) } + (s2, WorkerId new_unwrkr) } apply_to_details subst _ other = (subst, other) - -#ifdef DPH -applySubstToId (PodId d ity id ) - = ???? ToDo:DPH; not sure what! returnLft (PodId d ity (applySubstToId id)) -#endif {- Data Parallel Haskell -} -\end{code} - -\begin{code} -getIdNamePieces :: Bool {-show Uniques-} -> Id -> [FAST_STRING] - -getIdNamePieces show_uniqs (Id u ty info details) - = case details of - DataConId n _ _ _ _ _ -> - case (getOrigName n) of { (mod, name) -> - if fromPrelude mod then [name] else [mod, name] } - - TupleConId a -> [SLIT("Tup") _APPEND_ (_PK_ (show a))] - - ImportedId n -> get_fullname_pieces n - PreludeId n -> get_fullname_pieces n - TopLevId n -> get_fullname_pieces n - - SuperDictSelId c sc -> - case (getOrigName c) of { (c_mod, c_name) -> - case (getOrigName sc) of { (sc_mod, sc_name) -> - let - c_bits = if fromPreludeCore c - then [c_name] - else [c_mod, c_name] - - sc_bits= if fromPreludeCore sc - then [sc_name] - else [sc_mod, sc_name] - in - [SLIT("sdsel")] ++ c_bits ++ sc_bits }} - - ClassOpId clas op -> - case (getOrigName clas) of { (c_mod, c_name) -> - case (getClassOpString op) of { op_name -> - if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name] - } } - - DefaultMethodId clas op _ -> - case (getOrigName clas) of { (c_mod, c_name) -> - case (getClassOpString op) of { op_name -> - if fromPreludeCore clas - then [SLIT("defm"), op_name] - else [SLIT("defm"), c_mod, c_name, op_name] }} - - DictFunId c ty _ _ -> - case (getOrigName c) of { (c_mod, c_name) -> - let - c_bits = if fromPreludeCore c - then [c_name] - else [c_mod, c_name] - - ty_bits = getTypeString ty - in - [SLIT("dfun")] ++ c_bits ++ ty_bits } - - - ConstMethodId c ty o _ _ -> - case (getOrigName c) of { (c_mod, c_name) -> - case (getTypeString ty) of { ty_bits -> - case (getClassOpString o) of { o_name -> - case (if fromPreludeCore c - then [] - else [c_mod, c_name]) of { c_bits -> - [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}} - - -- if the unspecialised equiv is "top-level", - -- the name must be concocted from its name and the - -- names of the types to which specialised... - - SpecId unspec ty_maybes _ -> - getIdNamePieces show_uniqs unspec ++ ( - if not (toplevelishId unspec) - then [showUnique u] - else concat (map typeMaybeString ty_maybes) - ) - - WorkerId unwrkr -> - getIdNamePieces show_uniqs unwrkr ++ ( - if not (toplevelishId unwrkr) - then [showUnique u] - else [SLIT("wrk")] -- show u - ) - - InstId inst -> getInstNamePieces show_uniqs inst - LocalId n _ -> let local = getLocalName n in - if show_uniqs then [local, showUnique u] else [local] - SysLocalId n _ -> [getLocalName n, showUnique u] - SpecPragmaId n _ _ -> [getLocalName n, showUnique u] - -#ifdef DPH - ProcessorCon a _ -> ["MkProcessor" ++ (show a)] - PodId n ity id -> getIdNamePieces show_uniqs id ++ - ["mapped", "POD" ++ (show n), show ity] -#endif {- Data Parallel Haskell -} - -get_fullname_pieces :: FullName -> [FAST_STRING] -get_fullname_pieces n - = BIND (getOrigName n) _TO_ (mod, name) -> - if fromPrelude mod - then [name] - else [mod, name] - BEND -\end{code} - -Really Inst-ish, but only used in this module... -\begin{code} -getInstNamePieces :: Bool -> Inst -> [FAST_STRING] - -getInstNamePieces show_uniqs (Dict u clas ty _) - = let (mod, nm) = getOrigName clas in - if fromPreludeCore clas - then [SLIT("d"), nm, showUnique u] - else [SLIT("d"), mod, nm, showUnique u] - -getInstNamePieces show_uniqs (Method u id tys _) - = let local = getIdNamePieces show_uniqs id in - if show_uniqs then local ++ [showUnique u] else local - -getInstNamePieces show_uniqs (LitInst u _ _ _) = [SLIT("lit"), showUnique u] +-} \end{code} %************************************************************************ @@ -1199,63 +1004,29 @@ getInstNamePieces show_uniqs (LitInst u _ _ _) = [SLIT("lit"), showUnique u] %************************************************************************ \begin{code} -getIdUniType :: Id -> UniType - -getIdUniType (Id _ ty _ _) = ty - -#ifdef DPH --- ToDo: DPH -getIdUniType (ProcessorCon _ ty) = ty -getIdUniType (PodId d ity id) - = let (foralls,rho) = splitForalls (getIdUniType id) in - let tys = get_args rho in - let itys_mask = infoTypeNumToMask ity in - let tys' = zipWith convert tys itys_mask in - mkForallTy foralls (foldr1 mkFunTy tys') - where -- ToDo(hilly) change to use getSourceType etc... - - get_args ty = case (maybeUnpackFunTy ty) of - Nothing -> [ty] - Just (arg,res) -> arg:get_args res - - convert ty cond = if cond - then ty - else (coerce ty) - - coerce ty = case (maybeUnpackFunTy ty) of - Nothing ->mkPodizedPodNTy d ty - Just (arg,res) ->mkFunTy (coerce arg) (coerce res) -#endif {- Data Parallel Haskell -} +idType :: GenId ty -> ty + +idType (Id _ _ ty _ _ _) = ty \end{code} \begin{code} +{-LATER: getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class) getMentionedTyConsAndClassesFromId id - = getMentionedTyConsAndClassesFromUniType (getIdUniType id) + = getMentionedTyConsAndClassesFromType (idType id) +-} \end{code} \begin{code} -getIdKind i = kindFromType (getIdUniType i) +idPrimRep i = typePrimRep (idType i) \end{code} \begin{code} -getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod -getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod +{-LATER: +getInstIdModule (Id _ _ _ (DictFunId _ _ mod)) = mod +getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ mod)) = mod getInstIdModule other = panic "Id:getInstIdModule" -\end{code} - - -\begin{code} -{- NOT USED -getIdTauType :: Id -> TauType -getIdTauType i = expandTySyn (getTauType (getIdUniType i)) - -getIdSourceTypes :: Id -> [TauType] -getIdSourceTypes i = map expandTySyn (sourceTypes (getTauType (getIdUniType i))) - -getIdTargetType :: Id -> TauType -getIdTargetType i = expandTySyn (targetType (getTauType (getIdUniType i))) -} \end{code} @@ -1266,29 +1037,62 @@ getIdTargetType i = expandTySyn (targetType (getTauType (getIdUniType i))) %************************************************************************ \begin{code} -mkSuperDictSelId u c sc ty info = Id u ty info (SuperDictSelId c sc) -mkClassOpId u c op ty info = Id u ty info (ClassOpId c op) -mkDefaultMethodId u c op gen ty info = Id u ty info (DefaultMethodId c op gen) +mkSuperDictSelId u c sc ty info + = Id u n ty (SuperDictSelId c sc) NoPragmaInfo info + where + cname = getName c -- we get other info out of here -mkDictFunId u c ity full_ty from_here modname info - = Id u full_ty info (DictFunId c ity from_here modname) + n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname -mkConstMethodId u c op ity full_ty from_here modname info - = Id u full_ty info (ConstMethodId c ity op from_here modname) +mkMethodSelId u rec_c op ty info + = Id u n ty (MethodSelId rec_c op) NoPragmaInfo info + where + cname = getName rec_c -- we get other info out of here + + n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname + +mkDefaultMethodId u rec_c op gen ty info + = Id u n ty (DefaultMethodId rec_c op gen) NoPragmaInfo info + where + cname = getName rec_c -- we get other info out of here -mkWorkerId u unwrkr ty info = Id u ty info (WorkerId unwrkr) + n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname -mkInstId inst - = Id u (getInstUniType inst) noIdInfo (InstId inst) +mkDictFunId u c ity full_ty from_here locn mod info + = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info where - u = case inst of - Dict u c t o -> u - Method u i ts o -> u - LitInst u l ty o -> u - -{- UNUSED: -getSuperDictSelIdSig (Id _ _ _ (SuperDictSelId input_class result_class)) - = (input_class, result_class) + n = mkCompoundName2 u SLIT("dfun") [origName c] (getTypeString ity) from_here locn + +mkConstMethodId u c op ity full_ty from_here locn mod info + = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info + where + n = mkCompoundName2 u SLIT("const") [origName c, Unqual (classOpString op)] (getTypeString ity) from_here locn + +mkWorkerId u unwrkr ty info + = Id u n ty (WorkerId unwrkr) NoPragmaInfo info + where + unwrkr_name = getName unwrkr + + n = mkCompoundName u SLIT("wrk") [origName unwrkr_name] unwrkr_name + +mkInstId u ty name = Id u (changeUnique name u) ty (InstId (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." + ]) -} \end{code} @@ -1299,119 +1103,108 @@ getSuperDictSelIdSig (Id _ _ _ (SuperDictSelId input_class result_class)) %************************************************************************ \begin{code} -mkImported u n ty info = Id u ty info (ImportedId n) -mkPreludeId u n ty info = Id u ty info (PreludeId n) +mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info +mkPreludeId n ty info = Id (nameUnique n) n ty PreludeId NoPragmaInfo info -#ifdef DPH -mkPodId d i = PodId d i -#endif - -updateIdType :: Id -> UniType -> Id -updateIdType (Id u _ info details) ty = Id u ty info details +{-LATER: +updateIdType :: Id -> Type -> Id +updateIdType (Id u n _ info details) ty = Id u n ty info details +-} \end{code} \begin{code} -no_free_tvs ty = null (extractTyVarsFromTy ty) +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 -> UniType -> SrcLoc -> Id +mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b mkSysLocal str uniq ty loc - = Id uniq ty noIdInfo (SysLocalId (mkShortName str loc) (no_free_tvs ty)) + = Id uniq (mkLocalName uniq str True{-emph uniq-} loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo mkUserLocal str uniq ty loc - = Id uniq ty noIdInfo (LocalId (mkShortName str loc) (no_free_tvs ty)) + = Id uniq (mkLocalName uniq str False{-emph name-} loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo + +-- mkUserId builds a local or top-level Id, depending on the name given +mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b +mkUserId name ty pragma_info + | isLocalName name + = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo + | otherwise + = Id (nameUnique name) name ty + (if isLocallyDefinedName name then TopLevId else ImportedId) + pragma_info noIdInfo +\end{code} + + +\begin{code} +{-LATER: -- for a SpecPragmaId being created by the compiler out of thin air... -mkSpecPragmaId :: FAST_STRING -> Unique -> UniType -> Maybe SpecInfo -> SrcLoc -> Id -mkSpecPragmaId str uniq ty specinfo loc - = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specinfo (no_free_tvs ty)) +mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id +mkSpecPragmaId str uniq ty specid loc + = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty)) --- for new SpecId +-- for new SpecId mkSpecId u unspec ty_maybes ty info = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty)) + Id u n ty info (SpecId unspec ty_maybes (no_free_tvs ty)) -- Specialised version of constructor: only used in STG and code generation -- Note: The specialsied Id has the same unique as the unspeced Id -mkSameSpecCon ty_maybes unspec@(Id u ty info details) +mkSameSpecCon ty_maybes unspec@(Id u n ty info details) = ASSERT(isDataCon unspec) ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty)) + Id u n new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty)) where new_ty = specialiseTy ty ty_maybes 0 - -- pprTrace "SameSpecCon:Unique:" - -- (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes])) - --- mkId builds a local or top-level Id, depending on the name given -mkId :: Name -> UniType -> IdInfo -> Id -mkId (Short uniq short) ty info = Id uniq ty info (LocalId short (no_free_tvs ty)) -mkId (OtherTopId uniq full) ty info - = Id uniq ty info - (if isLocallyDefined full then TopLevId full else ImportedId full) - localiseId :: Id -> Id -localiseId id@(Id u ty info details) - = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty)) +localiseId id@(Id u n ty info details) + = Id u (mkShortName name loc) ty info (LocalId (no_free_tvs ty)) where - name = getOccurrenceName id + name = getOccName id loc = getSrcLoc id +-} --- this has to be one of the "local" flavours (LocalId, SysLocalId, InstId) --- ToDo: it does??? WDP mkIdWithNewUniq :: Id -> Unique -> Id -mkIdWithNewUniq (Id _ ty info details) uniq - = let - new_details - = case details of - InstId (Dict _ c t o) -> InstId (Dict uniq c t o) - InstId (Method _ i ts o) -> InstId (Method uniq i ts o) - InstId (LitInst _ l ty o) -> InstId (LitInst uniq l ty o) - old_details -> old_details - in - Id uniq ty info new_details - -#ifdef DPH -mkIdWithNewUniq (PodId d t id) uniq = PodId d t (mkIdWithNewUniq id uniq) -#endif {- Data Parallel Haskell -} +mkIdWithNewUniq (Id _ n ty details prag info) u + = Id u (changeUnique n u) ty details prag info \end{code} Make some local @Ids@ for a template @CoreExpr@. These have bogus @Uniques@, but that's OK because the templates are supposed to be instantiated before use. \begin{code} -mkTemplateLocals :: [UniType] -> [Id] +mkTemplateLocals :: [Type] -> [Id] mkTemplateLocals tys - = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc) + = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc) (getBuiltinUniques (length tys)) tys \end{code} \begin{code} -getIdInfo :: Id -> IdInfo +getIdInfo :: GenId ty -> IdInfo +getPragmaInfo :: GenId ty -> PragmaInfo -getIdInfo (Id _ _ info _) = info - -#ifdef DPH -getIdInfo (PodId _ _ id) = getIdInfo id -#endif {- Data Parallel Haskell -} +getIdInfo (Id _ _ _ _ _ info) = info +getPragmaInfo (Id _ _ _ _ info _) = info +{-LATER: replaceIdInfo :: Id -> IdInfo -> Id -replaceIdInfo (Id u ty _ details) info = Id u ty info details - -#ifdef DPH -replaceIdInfo (PodId dim ity id) info = PodId dim ity (replaceIdInfo id info) -#endif {- Data Parallel Haskell -} +replaceIdInfo (Id u n ty _ details) info = Id u n ty info details selectIdInfoForSpecId :: Id -> IdInfo selectIdInfoForSpecId unspec = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) noIdInfo `addInfo_UF` getIdUnfolding unspec +-} \end{code} %************************************************************************ @@ -1425,25 +1218,21 @@ of their arities; so it should not be asking... (but other things besides the code-generator need arity info!) \begin{code} -getIdArity :: Id -> ArityInfo -getDataConArity :: DataCon -> Int -- a simpler i/face; they always have arities - -#ifdef DPH -getIdArity (ProcessorCon n _) = mkArityInfo n -getIdArity (PodId _ _ id) = getIdArity id -#endif {- Data Parallel Haskell -} - -getIdArity (Id _ _ id_info _) = getInfo id_info +getIdArity :: Id -> ArityInfo +getIdArity (Id _ _ _ _ _ id_info) = getInfo id_info -getDataConArity id@(Id _ _ id_info _) +dataConArity :: DataCon -> Int +dataConArity id@(Id _ _ _ _ _ id_info) = ASSERT(isDataCon id) case (arityMaybe (getInfo id_info)) of - Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id) + Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id) Just i -> i +isNullaryDataCon con = dataConArity con == 0 -- function of convenience + addIdArity :: Id -> Int -> Id -addIdArity (Id u ty info details) arity - = Id u ty (info `addInfo` (mkArityInfo arity)) details +addIdArity (Id u n ty details pinfo info) arity + = Id u n ty details pinfo (info `addInfo` (mkArityInfo arity)) \end{code} %************************************************************************ @@ -1453,300 +1242,201 @@ addIdArity (Id u ty info details) arity %************************************************************************ \begin{code} -mkDataCon :: Unique{-DataConKey-} -> FullName -> [TyVarTemplate] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id - -- can get the tag and all the pieces of the type from the UniType - -mkDataCon k n tyvar_tmpls context args_tys tycon specenv = data_con +mkDataCon :: Name + -> [StrictnessMark] -> [FieldLabel] + -> [TyVar] -> ThetaType -> [TauType] -> TyCon +--ToDo: -> SpecEnv + -> Id + -- can get the tag and all the pieces of the type from the Type + +mkDataCon n stricts fields tvs ctxt args_tys tycon + = ASSERT(length stricts == length args_tys) + data_con where - data_con = Id k type_of_constructor datacon_info - (DataConId n - (position_within fIRST_TAG data_con_family data_con) - tyvar_tmpls context args_tys tycon) - - -- Note data_con self-recursion; - -- should be OK as tags are not looked at until - -- late in the game. - - data_con_family = getTyConDataCons tycon - - position_within :: Int -> [Id] -> Id -> Int - position_within acc [] con + -- NB: data_con self-recursion; should be OK as tags are not + -- looked at until late in the game. + data_con + = Id (nameUnique n) + n + type_of_constructor + (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon) + NoPragmaInfo + datacon_info + + data_con_tag = position_within fIRST_TAG data_con_family + + 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 - position_within acc (c:cs) con - = if c `eqId` con then acc else position_within (acc+(1::Int)) cs con - - type_of_constructor = mkSigmaTy tyvar_tmpls context - (glueTyArgs - args_tys - (applyTyCon tycon (map mkTyVarTemplateTy tyvar_tmpls))) + type_of_constructor + = mkSigmaTy tvs ctxt + (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs))) datacon_info = noIdInfo `addInfo_UF` unfolding `addInfo` mkArityInfo arity - `addInfo` specenv +--ToDo: `addInfo` specenv arity = length args_tys unfolding + = noInfo_UF +{- LATER: = -- if arity == 0 -- then noIdInfo -- else -- do some business... let - (tyvars, dict_vars, vars) = mk_uf_bits tyvar_tmpls context args_tys tycon - tyvar_tys = map mkTyVarTy tyvars + (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon + tyvar_tys = mkTyVarTys tyvars in - BIND (CoCon data_con tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon -> - - BIND (mkCoLam (dict_vars ++ vars) plain_CoCon) _TO_ lambdized_CoCon -> + case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con -> mkUnfolding EssentialUnfolding -- for data constructors - (foldr CoTyLam lambdized_CoCon tyvars) - BEND BEND + (mkLam tyvars (dict_vars ++ vars) plain_Con) + } - mk_uf_bits tyvar_tmpls context arg_tys tycon + mk_uf_bits tvs ctxt arg_tys tycon = let (inst_env, tyvars, tyvar_tys) - = instantiateTyVarTemplates tyvar_tmpls - (map getTheUnique tyvar_tmpls) + = instantiateTyVarTemplates tvs + (map uniqueOf tvs) in -- the "context" and "arg_tys" have TyVarTemplates in them, so -- we instantiate those types to have the right TyVars in them -- instead. - BIND (map (instantiateTauTy inst_env) (map ctxt_ty context)) - _TO_ inst_dict_tys -> - BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys -> + case (map (instantiateTauTy inst_env) (map ctxt_ty ctxt)) + of { inst_dict_tys -> + case (map (instantiateTauTy inst_env) arg_tys) of { inst_arg_tys -> -- We can only have **ONE** call to mkTemplateLocals here; -- otherwise, we get two blobs of locals w/ mixed-up Uniques -- (Mega-Sigh) [ToDo] - BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars -> + case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars -> - BIND (splitAt (length context) all_vars) _TO_ (dict_vars, vars) -> + case (splitAt (length ctxt) all_vars) of { (dict_vars, vars) -> (tyvars, dict_vars, vars) - BEND BEND BEND BEND + }}}} where - -- these are really dubious UniTypes, but they are only to make the + -- 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 +-} \end{code} \begin{code} mkTupleCon :: Arity -> Id -mkTupleCon arity = data_con +mkTupleCon arity + = Id unique n ty (TupleConId arity) NoPragmaInfo tuplecon_info where - data_con = Id unique ty tuplecon_info (TupleConId arity) - unique = mkTupleDataConUnique arity - ty = mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys)) + n = mkTupleDataConName arity + unique = uniqueOf n + ty = mkSigmaTy tyvars [] + (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys)) tycon = mkTupleTyCon arity tyvars = take arity alphaTyVars - tyvar_tys = map mkTyVarTemplateTy tyvars + tyvar_tys = mkTyVarTys tyvars tuplecon_info = noIdInfo `addInfo_UF` unfolding `addInfo` mkArityInfo arity - `addInfo` pcGenerateTupleSpecs arity ty +--LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty" unfolding + = noInfo_UF +{- LATER: = -- if arity == 0 -- then noIdInfo -- else -- do some business... let (tyvars, dict_vars, vars) = mk_uf_bits arity - tyvar_tys = map mkTyVarTy tyvars + tyvar_tys = mkTyVarTys tyvars in - BIND (CoCon data_con tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon -> - - BIND (mkCoLam (dict_vars ++ vars) plain_CoCon) _TO_ lambdized_CoCon -> - + case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con -> mkUnfolding EssentialUnfolding -- data constructors - (foldr CoTyLam lambdized_CoCon tyvars) - BEND BEND + (mkLam tyvars (dict_vars ++ vars) plain_Con) } mk_uf_bits arity - = BIND (mkTemplateLocals tyvar_tys) _TO_ vars -> - (tyvars, [], vars) - BEND + = case (mkTemplateLocals tyvar_tys) of { vars -> + (tyvars, [], vars) } where tyvar_tmpls = take arity alphaTyVars - (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getTheUnique tyvar_tmpls) - - -#ifdef DPH -mkProcessorCon :: Arity -> Id -mkProcessorCon arity - = ProcessorCon arity ty - where - ty = mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys)) - tycon = mkProcessorTyCon arity - tyvars = take arity alphaTyVars - tyvar_tys = map mkTyVarTemplateTy tyvars -#endif {- Data Parallel Haskell -} + (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls) +-} fIRST_TAG :: ConTag fIRST_TAG = 1 -- Tags allocated from here for real constructors - --- given one data constructor in a family, return a list --- of all the data constructors in that family. - -#ifdef DPH -getDataConFamily :: DataCon -> [DataCon] - -getDataConFamily data_con - = ASSERT(isDataCon data_con) - getTyConDataCons (getDataConTyCon data_con) -#endif \end{code} \begin{code} -getDataConTag :: DataCon -> ConTag -- will panic if not a DataCon +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 -getDataConTag (Id _ _ _ (DataConId _ tag _ _ _ _)) = tag -getDataConTag (Id _ _ _ (TupleConId _)) = fIRST_TAG -getDataConTag (Id _ _ _ (SpecId unspec _ _)) = getDataConTag unspec -#ifdef DPH -getDataConTag (ProcessorCon _ _) = fIRST_TAG -#endif {- Data Parallel Haskell -} +dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon +dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon +dataConTyCon (Id _ _ _ (TupleConId a) _ _) = mkTupleTyCon a -getDataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon - -getDataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ tycon)) = tycon -getDataConTyCon (Id _ _ _ (TupleConId a)) = mkTupleTyCon a -getDataConTyCon (Id _ _ _ (SpecId unspec tys _)) = mkSpecTyCon (getDataConTyCon unspec) tys -#ifdef DPH -getDataConTyCon (ProcessorCon a _) = mkProcessorTyCon a -#endif {- Data Parallel Haskell -} - -getDataConSig :: DataCon -> ([TyVarTemplate], ThetaType, [TauType], TyCon) +dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon) -- will panic if not a DataCon -getDataConSig (Id _ _ _ (DataConId _ _ tyvars theta_ty arg_tys tycon)) +dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _) = (tyvars, theta_ty, arg_tys, tycon) -getDataConSig (Id _ _ _ (TupleConId arity)) +dataConSig (Id _ _ _ (TupleConId arity) _ _) = (tyvars, [], tyvar_tys, mkTupleTyCon arity) where tyvars = take arity alphaTyVars - tyvar_tys = map mkTyVarTemplateTy tyvars - -getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _)) - = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon) - where - (tyvars, theta_ty, arg_tys, tycon) = getDataConSig unspec - - ty_env = tyvars `zip` ty_maybes - - spec_tyvars = foldr nothing_tyvars [] ty_env - nothing_tyvars (tyvar, Nothing) l = tyvar : l - nothing_tyvars (tyvar, Just ty) l = l - - spec_env = foldr just_env [] ty_env - just_env (tyvar, Nothing) l = l - just_env (tyvar, Just ty) l = (tyvar, ty) : l - spec_arg_tys = map (instantiateTauTy spec_env) arg_tys - - spec_theta_ty = if null theta_ty then [] - else panic "getDataConSig:ThetaTy:SpecDataCon" - spec_tycon = mkSpecTyCon tycon ty_maybes - -#ifdef DPH -getDataConSig (ProcessorCon arity _) - = (tyvars, [], tyvar_tys, mkProcessorTyCon arity) - where - tyvars = take arity alphaTyVars - tyvar_tys = map mkTyVarTemplateTy tyvars -#endif {- Data Parallel Haskell -} + tyvar_tys = mkTyVarTys tyvars + +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields +dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = [] + +dataConStrictMarks :: DataCon -> [StrictnessMark] +dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts +dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _) + = nOfThem arity NotMarkedStrict + +dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience +dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys } + +dataConArgTys :: DataCon + -> [Type] -- Instantiated at these types + -> [Type] -- Needs arguments of these types +dataConArgTys con_id inst_tys + = map (instantiateTy tenv) arg_tys + where + (tyvars, _, arg_tys, _) = dataConSig con_id + tenv = zipEqual "dataConArgTys" tyvars inst_tys \end{code} -@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 tycon_arg_tys - = ASSERT(isDataCon data_con) - --false?? WDP 95/06: ASSERT(not (maybeToBool (isSpecId_maybe data_con))) - let - (tv_tmpls, theta, cmpnt_ty_tmpls, tycon) = getDataConSig data_con - - inst_env = --ASSERT(length tv_tmpls == length tycon_arg_tys) -{- if (length tv_tmpls /= length tycon_arg_tys) then - pprPanic "Id:1666:" (ppCat [ppr PprShowAll data_con, ppr PprDebug tycon_arg_tys]) - else --} tv_tmpls `zip` tycon_arg_tys - - theta_tys = [ instantiateTauTy inst_env (mkDictTy c t) | (c,t) <- theta ] - cmpnt_tys = map (instantiateTauTy inst_env) cmpnt_ty_tmpls - result_ty = instantiateTauTy inst_env (applyTyCon tycon tycon_arg_tys) - in - -- Are the first/third results ever used? - (theta_tys, cmpnt_tys, result_ty) - -{- UNUSED: allows a specilaised constructor to be instantiated - (with all argument types of the unspecialsied tycon) - -getInstantiatedDataConSig data_con tycon_arg_tys - = ASSERT(isDataCon data_con) - if is_speccon && arg_tys_match_error then - pprPanic "getInstantiatedDataConSig:SpecId:" - (ppHang (ppr PprDebug data_con) 4 pp_match_error) - else - (theta_tys, cmpnt_tys, result_ty) -- Are the first/third results ever used? +mkRecordSelId field_label selector_ty + = Id (nameUnique name) + name + selector_ty + (RecordSelId field_label) + NoPragmaInfo + noIdInfo where - is_speccon = maybeToBool is_speccon_maybe - is_speccon_maybe = isSpecId_maybe data_con - Just (unspec_con, spec_tys) = is_speccon_maybe - - arg_tys_match_error = maybeToBool match_error_maybe - match_error_maybe = ASSERT(length spec_tys == length tycon_arg_tys) - argTysMatchSpecTys spec_tys tycon_arg_tys - (Just pp_match_error) = match_error_maybe - - (tv_tmpls, theta, cmpnt_ty_tmpls, tycon) - = if is_speccon - then getDataConSig unspec_con - else getDataConSig data_con - - inst_env = ASSERT(length tv_tmpls == length tycon_arg_tys) - tv_tmpls `zip` tycon_arg_tys - - theta_tys = [ instantiateTauTy inst_env (mkDictTy c t) | (c,t) <- theta ] - cmpnt_tys = map (instantiateTauTy inst_env) cmpnt_ty_tmpls - result_ty = instantiateTauTy inst_env (applyTyCon tycon tycon_arg_tys) --} -\end{code} + name = fieldLabelName field_label -The function @getDataConDeps@ is passed an @Id@ representing a data -constructor of some type. We look at the source types of the -constructor and create the set of all @TyCons@ referred to directly -from the source types. - -\begin{code} -#ifdef USE_SEMANTIQUE_STRANAL -getDataConDeps :: Id -> [TyCon] - -getDataConDeps (Id _ _ _ (DataConId _ _ _ _ arg_tys _)) - = concat (map getReferredToTyCons arg_tys) -getDataConDeps (Id _ _ _ (TupleConId _)) = [] -getDataConDeps (Id _ _ _ (SpecId unspec ty_maybes _)) - = getDataConDeps unspec ++ concat (map getReferredToTyCons (catMaybes ty_maybes)) -#ifdef DPH -getDataConDeps (ProcessorCon _ _) = [] -#endif {- Data Parallel Haskell -} -#endif {- Semantique strictness analyser -} +recordSelectorFieldLabel :: Id -> FieldLabel +recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl \end{code} + Data type declarations are of the form: \begin{verbatim} data Foo a b = C1 ... | C2 ... | ... | Cn ... @@ -1754,9 +1444,9 @@ data Foo a b = C1 ... | C2 ... | ... | Cn ... For each constructor @Ci@, we want to generate a curried function; so, e.g., for @C1 x y z@, we want a function binding: \begin{verbatim} -fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> CoCon C1 [a, b] [x, y, z] +fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z] \end{verbatim} -Notice the ``big lambdas'' and type arguments to @CoCon@---we are producing +Notice the ``big lambdas'' and type arguments to @Con@---we are producing 2nd-order polymorphic lambda calculus with explicit types. %************************************************************************ @@ -1781,36 +1471,13 @@ dictionaries, in the even of an overloaded data-constructor---none at present.) \begin{code} -getIdUnfolding :: Id -> UnfoldingDetails +getIdUnfolding :: Id -> UnfoldingDetails -#ifdef DPH -getIdUnfolding dcon@(ProcessorCon arity _) - = let - (tyvars, dict_vars, vars) = getDataConUnfolding dcon - tyvar_tys = map mkTyVarTy tyvars - in - BIND (CoCon dcon tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon -> - BIND (mkCoLam vars plain_CoCon) _TO_ lambdized_CoCon -> - mkUnfoldTemplate (\x->False){-ToDo-} EssentialUnfolding{-ToDo???DPH-} (foldr CoTyLam lambdized_CoCon tyvars) - BEND BEND - --- If we have a PodId whose ``id'' has an unfolding, then we need to --- parallelize the unfolded expression for the d^th dimension. -{- -getIdUnfolding (PodId d _ id) - = case (unfoldingMaybe (getIdUnfolding id)) of - Nothing -> noInfo - Just expr -> trace ("getIdUnfolding ("++ - ppShow 80 (ppr PprDebug id) ++ - ") for " ++ show d ++ "D pod") - (podizeTemplateExpr d expr) --} -#endif {- Data Parallel Haskell -} - -getIdUnfolding (Id _ _ id_info _) = getInfo_UF id_info +getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info +{-LATER: addIdUnfolding :: Id -> UnfoldingDetails -> Id -addIdUnfolding id@(Id u ty info details) unfold_details +addIdUnfolding id@(Id u n ty info details) unfold_details = ASSERT( case (isLocallyDefined id, unfold_details) of (_, NoUnfoldingDetails) -> True @@ -1819,11 +1486,7 @@ addIdUnfolding id@(Id u ty info details) unfold_details (False, _) -> True _ -> False -- v bad ) - Id u ty (info `addInfo_UF` unfold_details) details - -{- UNUSED: -clearIdUnfolding :: Id -> Id -clearIdUnfolding (Id u ty info details) = Id u ty (clearInfo_UF info) details + Id u n ty (info `addInfo_UF` unfold_details) details -} \end{code} @@ -1838,25 +1501,6 @@ class Foo a { op :: Complex b => c -> b -> a } # note local polymorphism... \end{verbatim} -For data constructors, we make an unfolding which has a bunch of -lambdas to bind the arguments, with a (saturated) @CoCon@ inside. In -the case of overloaded constructors, the dictionaries are just thrown -away; they were only required in the first place to ensure that the -type was indeed an instance of the required class. -\begin{code} -#ifdef DPH -getDataConUnfolding :: Id -> ([TyVar], [Id], [Id]) - -getDataConUnfolding dcon@(ProcessorCon arity _) - = BIND (mkTemplateLocals tyvar_tys) _TO_ vars -> - (tyvars, [], vars) - BEND - where - tyvar_tmpls = take arity alphaTyVars - (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getTheUnique tyvar_tmpls) -#endif {- Data Parallel Haskell -} -\end{code} - %************************************************************************ %* * \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@} @@ -1865,47 +1509,53 @@ getDataConUnfolding dcon@(ProcessorCon arity _) \begin{code} getIdDemandInfo :: Id -> DemandInfo -getIdDemandInfo (Id _ _ info _) = getInfo info +getIdDemandInfo (Id _ _ _ _ _ info) = getInfo info addIdDemandInfo :: Id -> DemandInfo -> Id -addIdDemandInfo (Id u ty info details) demand_info - = Id u ty (info `addInfo` demand_info) details +addIdDemandInfo (Id u n ty details prags info) demand_info + = Id u n ty details prags (info `addInfo` demand_info) \end{code} \begin{code} getIdUpdateInfo :: Id -> UpdateInfo -getIdUpdateInfo (Id u ty info details) = getInfo info +getIdUpdateInfo (Id _ _ _ _ _ info) = getInfo info addIdUpdateInfo :: Id -> UpdateInfo -> Id -addIdUpdateInfo (Id u ty info details) upd_info - = Id u ty (info `addInfo` upd_info) details +addIdUpdateInfo (Id u n ty details prags info) upd_info + = Id u n ty details prags (info `addInfo` upd_info) \end{code} \begin{code} +{- LATER: getIdArgUsageInfo :: Id -> ArgUsageInfo -getIdArgUsageInfo (Id u ty info details) = getInfo info +getIdArgUsageInfo (Id u n ty info details) = getInfo info addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id -addIdArgUsageInfo (Id u ty info details) au_info - = Id u ty (info `addInfo` au_info) details +addIdArgUsageInfo (Id u n ty info details) au_info + = Id u n ty (info `addInfo` au_info) details +-} \end{code} \begin{code} +{- LATER: getIdFBTypeInfo :: Id -> FBTypeInfo -getIdFBTypeInfo (Id u ty info details) = getInfo info +getIdFBTypeInfo (Id u n ty info details) = getInfo info addIdFBTypeInfo :: Id -> FBTypeInfo -> Id -addIdFBTypeInfo (Id u ty info details) upd_info - = Id u ty (info `addInfo` upd_info) details +addIdFBTypeInfo (Id u n ty info details) upd_info + = Id u n ty (info `addInfo` upd_info) details +-} \end{code} \begin{code} +{- LATER: getIdSpecialisation :: Id -> SpecEnv -getIdSpecialisation (Id _ _ info _) = getInfo info +getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info addIdSpecialisation :: Id -> SpecEnv -> Id -addIdSpecialisation (Id u ty info details) spec_info - = Id u ty (info `addInfo` spec_info) details +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. @@ -1913,12 +1563,12 @@ Strictness: we snaffle the info out of the IdInfo. \begin{code} getIdStrictness :: Id -> StrictnessInfo -getIdStrictness (Id _ _ id_info _) = getInfo id_info +getIdStrictness (Id _ _ _ _ _ info) = getInfo info addIdStrictness :: Id -> StrictnessInfo -> Id -addIdStrictness (Id u ty info details) strict_info - = Id u ty (info `addInfo` strict_info) details +addIdStrictness (Id u n ty details prags info) strict_info + = Id u n ty details prags (info `addInfo` strict_info) \end{code} %************************************************************************ @@ -1930,33 +1580,30 @@ addIdStrictness (Id u ty info details) strict_info Comparison: equality and ordering---this stuff gets {\em hammered}. \begin{code} -cmpId (Id u1 _ _ _) (Id u2 _ _ _) = cmpUnique u1 u2 +cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = cmp u1 u2 -- short and very sweet \end{code} \begin{code} -eqId :: Id -> Id -> Bool - -eqId a b = case cmpId a b of { EQ_ -> True; _ -> False } - -instance Eq Id where - a == b = case cmpId a b of { EQ_ -> True; _ -> False } - a /= b = case cmpId a b of { EQ_ -> False; _ -> True } - -instance Ord Id 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 } -#ifdef __GLASGOW_HASKELL__ - _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } -#endif +instance Ord3 (GenId ty) where + cmp = cmpId + +instance Eq (GenId ty) where + a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } + a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + +instance Ord (GenId ty) where + a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } + _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } \end{code} @cmpId_withSpecDataCon@ ensures that any spectys are taken into account when comparing two data constructors. We need to do this -because a specialsied data constructor has the same unique as its -unspeciailsed counterpart. +because a specialised data constructor has the same Unique as its +unspecialised counterpart. \begin{code} cmpId_withSpecDataCon :: Id -> Id -> TAG_ @@ -1971,18 +1618,12 @@ cmpId_withSpecDataCon id1 id2 cmp_ids = cmpId id1 id2 eq_ids = case cmp_ids of { EQ_ -> True; other -> False } -cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _)) (Id _ _ _ (SpecId _ mtys2 _)) - = cmpUniTypeMaybeList mtys1 mtys2 - -cmpEqDataCon unspec1 (Id _ _ _ (SpecId _ _ _)) - = LT_ - -cmpEqDataCon (Id _ _ _ (SpecId _ _ _)) unspec2 - = GT_ - -cmpEqDataCon unspec1 unspec2 - = EQ_ +cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _) + = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2" +cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_ +cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_ +cmpEqDataCon _ _ = EQ_ \end{code} %************************************************************************ @@ -1992,7 +1633,11 @@ cmpEqDataCon unspec1 unspec2 %************************************************************************ \begin{code} -instance Outputable Id where +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 @@ -2005,269 +1650,231 @@ showId sty id = ppShow 80 (pprId sty id) -- class and tycon are from PreludeCore [non-std, but convenient] -- *and* the thing was defined in this module. -instance_export_flag :: Class -> UniType -> Bool -> ExportFlag +instance_export_flag :: Class -> Type -> Bool -> ExportFlag instance_export_flag clas inst_ty from_here + = panic "Id:instance_export_flag" +{-LATER = if instanceIsExported clas inst_ty from_here then ExportAll else NotExported +-} \end{code} -Do we consider an ``instance type'' (as on a @DictFunId@) to be ``from -PreludeCore''? True if the outermost TyCon is fromPreludeCore. +Default printing code (not used for interfaces): \begin{code} -is_prelude_core_ty :: UniType -> Bool +pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty -is_prelude_core_ty inst_ty - = case getUniDataTyCon_maybe inst_ty of - Just (tycon,_,_) -> fromPreludeCore tycon - Nothing -> panic "Id: is_prelude_core_ty" +pprId sty (Id u n _ _ _ _) = ppr sty n + -- WDP 96/05/06: We can re-elaborate this as we go along... \end{code} -Default printing code (not used for interfaces): \begin{code} -pprId :: PprStyle -> Id -> Pretty +idUnique (Id u _ _ _ _ _) = u -pprId other_sty id - = let - pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id +instance Uniquable (GenId ty) where + uniqueOf = idUnique - for_code - = let - pieces_to_print -- maybe use Unique only - = if isSysLocalId id then tail pieces else pieces - in - ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print) - in - case other_sty of - PprForC _ -> for_code - PprForAsm _ _ _ -> for_code - PprInterface _ -> ppPStr occur_name - PprForUser -> ppPStr occur_name - PprUnfolding _ -> qualified_name pieces - PprDebug -> qualified_name pieces - PprShowAll -> ppBesides [qualified_name pieces, - (ppCat [pp_uniq id, - ppPStr SLIT("{-"), - ppr other_sty (getIdUniType id), - ppIdInfo other_sty id True (\x->x) nullIdEnv (getIdInfo id), - ppPStr SLIT("-}") ])] - where - occur_name = getOccurrenceName id _APPEND_ - ( _PK_ (if not (isSysLocalId id) - then "" - else "." ++ (_UNPK_ (showUnique (getTheUnique 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 -- No uniq to add - pp_uniq (Id _ _ _ (TupleConId _)) = ppNil -- No uniq to add - pp_uniq (Id _ _ _ (LocalId _ _)) = ppNil -- uniq printed elsewhere - pp_uniq (Id _ _ _ (SysLocalId _ _)) = ppNil -- ditto - pp_uniq (Id _ _ _ (SpecPragmaId _ _ _)) = ppNil -- ditto - pp_uniq (Id _ _ _ (InstId _)) = ppNil -- ditto - pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getTheUnique other_id), ppPStr SLIT("-}")] - - -- For Robin Popplestone: print PprDebug Ids with # afterwards - -- if they are of primitive type. - pp_ubxd pretty = if isPrimType (getIdUniType id) - then ppBeside pretty (ppChar '#') - else pretty -\end{code} - -\begin{code} -instance NamedThing Id where - getExportFlag (Id _ _ _ details) +instance NamedThing (GenId ty) where + getName this_id@(Id u n _ details _ _) = n +{- OLD: = get details where - get (DataConId _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName - get (TupleConId _) = NotExported - get (ImportedId n) = getExportFlag n - get (PreludeId n) = getExportFlag n - get (TopLevId n) = getExportFlag n - get (SuperDictSelId c _) = getExportFlag c - get (ClassOpId c _) = getExportFlag c - get (DefaultMethodId c _ _) = getExportFlag c - get (DictFunId c ty from_here _) = instance_export_flag c ty from_here - get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here - get (SpecId unspec _ _) = getExportFlag unspec - get (WorkerId unwrkr) = getExportFlag unwrkr - get (InstId _) = NotExported - get (LocalId _ _) = NotExported - get (SysLocalId _ _) = NotExported - get (SpecPragmaId _ _ _) = NotExported -#ifdef DPH - get (ProcessorCon _ _) = NotExported - get (PodId _ _ i) = getExportFlag i -#endif {- Data Parallel Haskell -} - - isLocallyDefined this_id@(Id _ _ _ details) - = get details - where - get (DataConId _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName - get (TupleConId _) = False - get (ImportedId _) = False - get (PreludeId _) = False - get (TopLevId n) = isLocallyDefined n - get (SuperDictSelId c _) = isLocallyDefined c - get (ClassOpId c _) = isLocallyDefined c - get (DefaultMethodId c _ _) = isLocallyDefined c - get (DictFunId c tyc from_here _) = from_here - -- For DictFunId and ConstMethodId things, you really have to - -- know whether it came from an imported instance or one - -- really here; no matter where the tycon and class came from. - - get (ConstMethodId c tyc _ from_here _) = from_here - get (SpecId unspec _ _) = isLocallyDefined unspec - get (WorkerId unwrkr) = isLocallyDefined unwrkr - get (InstId _) = True - get (LocalId _ _) = True - get (SysLocalId _ _) = True - get (SpecPragmaId _ _ _) = True -#ifdef DPH - get (ProcessorCon _ _) = False - get (PodId _ _ i) = isLocallyDefined i -#endif {- Data Parallel Haskell -} - - getOrigName this_id@(Id u _ _ details) - = get details - where - get (DataConId n _ _ _ _ _) = getOrigName n - get (TupleConId a) = (pRELUDE_BUILTIN, SLIT("Tup") _APPEND_ _PK_ (show a)) - get (ImportedId n) = getOrigName n - get (PreludeId n) = getOrigName n - get (TopLevId n) = getOrigName n - - get (ClassOpId c op) = case (getOrigName c) of -- ToDo; better ??? - (mod, _) -> (mod, getClassOpString op) + get (LocalId _) = n + get (SysLocalId _) = n + get (SpecPragmaId _ _) = n + get ImportedId = n + get PreludeId = n + get TopLevId = n + get (InstId n _) = n + get (DataConId _ _ _ _ _ _ _) = n + get (TupleConId _) = n + get (RecordSelId l) = getName l + get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id) +-} +{- LATER: + get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ??? + mod -> (mod, classOpString op) get (SpecId unspec ty_maybes _) - = BIND getOrigName unspec _TO_ (mod, unspec_nm) -> - BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix -> + = case moduleNamePair unspec of { (mod, unspec_nm) -> + case specMaybeTysSuffix ty_maybes of { tys_suffix -> (mod, unspec_nm _APPEND_ (if not (toplevelishId unspec) then showUnique u else tys_suffix) - ) - BEND BEND + ) }} get (WorkerId unwrkr) - = BIND getOrigName unwrkr _TO_ (mod, unwrkr_nm) -> + = case moduleNamePair unwrkr of { (mod, unwrkr_nm) -> (mod, unwrkr_nm _APPEND_ (if not (toplevelishId unwrkr) then showUnique u else SLIT(".wrk")) - ) - BEND - - get (InstId inst) - = (panic "NamedThing.Id.getOrigName (InstId)", - BIND (getInstNamePieces True inst) _TO_ (piece1:pieces) -> - BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces -> - _CONCAT_ (piece1 : dotted_pieces) - BEND BEND ) - - get (LocalId n _) = (panic "NamedThing.Id.getOrigName (LocalId)", - getLocalName n) - get (SysLocalId n _) = (panic "NamedThing.Id.getOrigName (SysLocal)", - getLocalName n) - get (SpecPragmaId n _ _)=(panic "NamedThing.Id.getOrigName (SpecPragmaId)", - getLocalName n) -#ifdef DPH - get (ProcessorCon a _) = ("PreludeBuiltin", - "MkProcessor" ++ (show a)) - get (PodId d ity id) - = BIND (getOrigName id) _TO_ (m,n) -> - (m,n ++ ".mapped.POD"++ show d ++ "." ++ show ity) - BEND - -- ToDo(hilly): should the above be using getIdNamePieces??? -#endif {- Data Parallel Haskell -} + ) } 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 + = case (getIdNamePieces True this_id) of { (piece1:pieces) -> + case [ _CONS_ '.' p | p <- pieces ] of { dotted_pieces -> + (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) }} +-} +\end{code} - getOccurrenceName this_id@(Id _ _ _ details) - = get details - where - get (DataConId n _ _ _ _ _) = getOccurrenceName n - get (TupleConId a) = SLIT("Tup") _APPEND_ (_PK_ (show a)) - get (ImportedId n) = getOccurrenceName n - get (PreludeId n) = getOccurrenceName n - get (TopLevId n) = getOccurrenceName n - get (ClassOpId _ op) = getClassOpString op -#ifdef DPH - get (ProcessorCon a _) = "MkProcessor" ++ (show a) - get (PodId _ _ id) = getOccurrenceName id -#endif {- Data Parallel Haskell -} - get _ = snd (getOrigName this_id) - - getInformingModules id = panic "getInformingModule:Id" - - getSrcLoc (Id _ _ id_info details) - = get details - where - get (DataConId n _ _ _ _ _) = getSrcLoc n - get (TupleConId _) = mkBuiltinSrcLoc - get (ImportedId n) = getSrcLoc n - get (PreludeId n) = getSrcLoc n - get (TopLevId n) = getSrcLoc n - get (SuperDictSelId c _)= getSrcLoc c - get (ClassOpId c _) = getSrcLoc c - get (SpecId unspec _ _) = getSrcLoc unspec - get (WorkerId unwrkr) = getSrcLoc unwrkr - get (InstId i) = let (loc,_) = getInstOrigin i - in loc - get (LocalId n _) = getSrcLoc n - get (SysLocalId n _) = getSrcLoc n - get (SpecPragmaId n _ _)= getSrcLoc n -#ifdef DPH - get (ProcessorCon _ _) = mkBuiltinSrcLoc - get (PodId _ _ n) = getSrcLoc n -#endif {- Data Parallel Haskell -} - -- well, try the IdInfo - get something_else = getSrcLocIdInfo id_info - - getTheUnique (Id u _ _ _) = u - - fromPreludeCore (Id _ _ _ details) - = get details - where - get (DataConId _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName - get (TupleConId _) = True - get (ImportedId n) = fromPreludeCore n - get (PreludeId n) = fromPreludeCore n - get (TopLevId n) = fromPreludeCore n - get (SuperDictSelId c _) = fromPreludeCore c - get (ClassOpId c _) = fromPreludeCore c - get (DefaultMethodId c _ _) = fromPreludeCore c - get (DictFunId c t _ _) = fromPreludeCore c && is_prelude_core_ty t - get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t - get (SpecId unspec _ _) = fromPreludeCore unspec - get (WorkerId unwrkr) = fromPreludeCore unwrkr - get (InstId _) = False - get (LocalId _ _) = False - get (SysLocalId _ _) = False - get (SpecPragmaId _ _ _) = False -#ifdef DPH - get (ProcessorCon _ _) = True - get (PodId _ _ id) = fromPreludeCore id -#endif {- Data Parallel Haskell -} - - hasType id = True - getType id = getIdUniType id +Note: The code generator doesn't carry a @UniqueSupply@, so it uses +the @Uniques@ out of local @Ids@ given to it. + +%************************************************************************ +%* * +\subsection{@IdEnv@s and @IdSet@s} +%* * +%************************************************************************ + +\begin{code} +type IdEnv elt = UniqFM elt + +nullIdEnv :: IdEnv a + +mkIdEnv :: [(GenId ty, a)] -> IdEnv a +unitIdEnv :: GenId ty -> a -> IdEnv a +addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a +growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a +growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a + +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 +rngIdEnv :: IdEnv a -> [a] + +isNullIdEnv :: IdEnv a -> Bool +lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a +lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a +\end{code} + +\begin{code} +addOneToIdEnv = addToUFM +combineIdEnvs = plusUFM_C +delManyFromIdEnv = delListFromUFM +delOneFromIdEnv = delFromUFM +growIdEnv = plusUFM +lookupIdEnv = lookupUFM +mapIdEnv = mapUFM +mkIdEnv = listToUFM +nullIdEnv = emptyUFM +rngIdEnv = eltsUFM +unitIdEnv = unitUFM + +growIdEnvList env pairs = plusUFM env (listToUFM pairs) +isNullIdEnv env = sizeUFM env == 0 +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 + = case (lookupIdEnv env key) of + Nothing -> env + Just xx -> addOneToIdEnv env key (mangle_fn xx) \end{code} -Reason for @getTheUnique@: The code generator doesn't carry a -@UniqueSupply@, so it wants to use the @Uniques@ out of local @Ids@ -given to it. +\begin{code} +type GenIdSet ty = UniqSet (GenId ty) +type IdSet = UniqSet (GenId Type) + +emptyIdSet :: GenIdSet ty +intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty +unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty +unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty +idSetToList :: GenIdSet ty -> [GenId ty] +unitIdSet :: GenId ty -> GenIdSet ty +addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty +elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool +minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty +isEmptyIdSet :: GenIdSet ty -> Bool +mkIdSet :: [GenId ty] -> GenIdSet ty + +emptyIdSet = emptyUniqSet +unitIdSet = unitUniqSet +addOneToIdSet = addOneToUniqSet +intersectIdSets = intersectUniqSets +unionIdSets = unionUniqSets +unionManyIdSets = unionManyUniqSets +idSetToList = uniqSetToList +elementOfIdSet = elementOfUniqSet +minusIdSet = minusUniqSet +isEmptyIdSet = isEmptyUniqSet +mkIdSet = mkUniqSet +\end{code} + +\begin{code} +addId, nmbrId :: Id -> NmbrM Id + +addId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) + = case (lookupUFM_Directly idenv u) of + Just xx -> _trace "addId: already in map!" $ + (nenv, xx) + Nothing -> + if toplevelishId id then + _trace "addId: can't add toplevelish!" $ + (nenv, id) + else -- alloc a new unique for this guy + -- and add an entry in the idenv + -- NB: *** KNOT-TYING *** + let + nenv_plus_id = NmbrEnv (incrUnique ui) ut uu + (addToUFM_Directly idenv u new_id) + tvenv uvenv + + (nenv2, new_ty) = nmbrType ty nenv_plus_id + (nenv3, new_det) = nmbr_details det nenv2 + + new_id = Id ui n new_ty new_det prag info + in + (nenv3, new_id) + +nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) + = case (lookupUFM_Directly idenv u) of + Just xx -> (nenv, xx) + Nothing -> + if not (toplevelishId id) then + _trace "nmbrId: lookup failed" $ + (nenv, id) + else + let + (nenv2, new_ty) = nmbrType ty nenv + (nenv3, new_det) = nmbr_details det nenv2 + + new_id = Id u n new_ty new_det prag info + in + (nenv3, new_id) + +------------ +nmbr_details :: IdDetails -> NmbrM IdDetails + +nmbr_details (DataConId tag marks fields tvs theta arg_tys tc) + = mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs -> + mapNmbr nmbrField fields `thenNmbr` \ new_fields -> + mapNmbr nmbr_theta theta `thenNmbr` \ new_theta -> + mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys -> + returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_arg_tys tc) + where + nmbr_theta (c,t) + = --nmbrClass c `thenNmbr` \ new_c -> + nmbrType t `thenNmbr` \ new_t -> + returnNmbr (c, new_t) + + -- ToDo:add more cases as needed +nmbr_details other_details = returnNmbr other_details + +------------ +nmbrField (FieldLabel n ty tag) + = nmbrType ty `thenNmbr` \ new_ty -> + returnNmbr (FieldLabel n new_ty tag) +\end{code}