X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=75f15203677acde1dc8b6e65a6b294d4a50a04d2;hb=f9120c200bcf613b58d742802172fb4c08171f0d;hp=a9b3b7e1452a3985781696e8ccd96887e71d4963;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index a9b3b7e..75f1520 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -1,62 +1,58 @@ % -% (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 mkSysLocal, mkUserLocal, mkSpecPragmaId, mkSpecId, mkSameSpecCon, + selectIdInfoForSpecId, mkTemplateLocals, 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, + idType, + getIdInfo, replaceIdInfo, + getPragmaInfo, + idPrimRep, getInstIdModule, getMentionedTyConsAndClassesFromId, - getDataConTag, - getDataConSig, getInstantiatedDataConSig, - getDataConTyCon, -- UNUSED: getDataConFamily, -#ifdef USE_SEMANTIQUE_STRANAL - getDataConDeps, -#endif + + dataConTag, + dataConSig, getInstantiatedDataConSig, + dataConTyCon, dataConArity, + dataConFieldLabels, + + recordSelectorFieldLabel, -- PREDICATES - isDataCon, isTupleCon, isNullaryDataCon, + isDataCon, isTupleCon, isSpecId_maybe, isSpecPragmaId_maybe, toplevelishId, externallyVisibleId, isTopLevId, isWorkerId, isWrapperId, isImportedId, isSysLocalId, isBottomingId, - isClassOpId, isConstMethodId, isDefaultMethodId, - isDictFunId, isInstId_maybe, isSuperDictSelId_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, @@ -69,11 +65,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, @@ -85,100 +81,107 @@ 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 + -- "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_Trace -- ToDo: rm (debugging only) + -- and to make the interface self-sufficient... + GenIdSet(..), IdSet(..) + )-} where -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 -} - ) +import Ubiq +import IdLoop -- for paranoia checking +import 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 ( pcGenerateDataSpecs ) -- PRETTY GRIMY TO LOOK IN HERE +import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp ) +import CStrings ( identToC, cSEP ) +import IdInfo +import Maybes ( maybeToBool ) +import Name ( appendRdr, nameUnique, mkLocalName, isLocalName, + isLocallyDefinedName, isPreludeDefinedName, + nameOrigName, + RdrName(..), Name + ) +import FieldLabel ( fieldLabelName, FieldLabel{-instances-} ) +import Outputable ( isAvarop, isAconop, getLocalName, + isLocallyDefined, isPreludeDefined, + getOrigName, getOccName, + isExported, ExportFlag(..) + ) +import PragmaInfo ( PragmaInfo(..) ) +import PrelMods ( pRELUDE_BUILTIN ) +import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix, + GenType, GenTyVar + ) +import PprStyle +import Pretty +import SrcLoc ( mkBuiltinSrcLoc ) +import TyCon ( TyCon, mkTupleTyCon, tyConDataCons ) +import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy, + applyTyCon, isPrimType, instantiateTy, + tyVarsOfType, applyTypeEnvToTy, typePrimRep, + GenType, ThetaType(..), TauType(..), Type(..) + ) +import 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 UniqSupply ( getBuiltinUniques ) +import Unique ( mkTupleDataConUnique, pprUnique, showUnique, + Unique{-instance Ord3-} + ) +import Util ( mapAccumL, nOfThem, + 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 + 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 + = LocalId Name -- Local name; mentioned by the user Bool -- True <=> no free type vars - | SysLocalId ShortName -- made up by the compiler + | SysLocalId Name -- Local name; made up by the compiler Bool -- as for LocalId - | SpecPragmaId ShortName -- introduced by the compiler - (Maybe SpecInfo)-- for explicit specid in pragma - Bool -- as for LocalId + | SpecPragmaId Name -- 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 Name -- Global name (Imported or Implicit); Id imported from an interface - | PreludeId FullName -- things < Prelude that compiler "knows" about + | PreludeId Name -- Global name (Builtin); Builtin prelude Ids - | TopLevId FullName -- Top-level in the orig source pgm + | TopLevId Name -- Global name (LocalDef); Top-level in the orig source pgm -- (not moved there by transformations). -- a TopLevId's type may contain free type variables, if @@ -186,24 +189,20 @@ data IdDetails ---------------- Data constructors - | DataConId FullName + | DataConId Name 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)]" + [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 + | TupleConId Name + Int -- Its arity -#ifdef DPH - | ProcessorCon Int -- Its arity -#endif {- Data Parallel Haskell -} + | RecordSelId FieldLabel ---------------- Things to do with overloading @@ -211,24 +210,67 @@ 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. + Bool -- True <=> from an instance decl in this mod + (Maybe Module) -- module where instance came from; Nothing => Prelude + + -- see below + | ConstMethodId -- A method which depends only on the type of the + -- instance, and not on any further dictionaries etc. + Class -- Uniquely identified by: + Type -- (class, type, classop) triple + ClassOp + Bool -- True => from an instance decl in this mod + (Maybe Module) -- module where instance came from; Nothing => Prelude + + | InstId Name -- An instance of a dictionary, class operation, + -- or overloaded value (Local name) + Bool -- as for LocalId + + | SpecId -- A specialisation of another Id + Id -- Id of which this is a specialisation + [Maybe Type] -- Types at which it is specialised; + -- A "Nothing" says this type ain't relevant. + Bool -- True <=> no free type vars; it's not enough + -- to know about the unspec version, because + -- we may specialise to a type w/ free tyvars + -- (i.e., in one of the "Maybe Type" dudes). + + | WorkerId -- A "worker" for some other Id + Id -- Id for which this is a worker + + +type ConTag = Int +type DictVar = Id +type DictFun = Id +type DataCon = Id \end{code} + DictFunIds are generated from instance decls. \begin{verbatim} class Foo a where @@ -250,20 +292,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 -\end{code} Constant method ids are generated from instance decls where there is no context; that is, no dictionaries are needed to @@ -291,47 +323,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 - - | 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} @@ -341,7 +338,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. @@ -350,7 +347,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. %---------------------------------------------------------------------- @@ -368,7 +365,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. @@ -384,7 +381,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. %---------------------------------------------------------------------- @@ -434,7 +431,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 @@ -449,7 +446,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} @@ -457,44 +453,35 @@ 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 ty d p i) = Id u (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 @@ -507,165 +494,118 @@ about something if it returns @True@! 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 (InstId _ no_free_tvs) = no_free_tvs chk (SpecId _ _ no_free_tvs) = no_free_tvs chk (LocalId _ no_free_tvs) = no_free_tvs chk (SysLocalId _ no_free_tvs) = no_free_tvs chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs -#ifdef DPH - chk (ProcessorCon _ _) = True - chk (PodId _ _ id) = idHasNoFreeTyVars id -#endif {- Data Parallel Haskell -} \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 (Id _ _ _ (DefaultMethodId _ _ _)) = True -#ifdef DPH -isDefaultMethodId (PodId _ _ id) = isDefaultMethodId id -#endif {- Data Parallel Haskell -} -isDefaultMethodId other = False - -isDictFunId (Id _ _ _ (DictFunId _ _ _)) = True -#ifdef DPH -isDictFunId (PodId _ _ id) = isDictFunId id -#endif {- Data Parallel Haskell -} -isDictFunId other = False - -isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _)) = True -#ifdef DPH -isConstMethodId (PodId _ _ id) = isConstMethodId id -#endif {- Data Parallel Haskell -} -isConstMethodId other = False - -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 @@ -674,21 +614,23 @@ pprIdInUnfolding in_scopes v -- these ones' exportedness checked later... TopLevId _ -> pp_full_name - DataConId _ _ _ _ _ _ -> 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 @@ -721,15 +663,15 @@ pprIdInUnfolding in_scopes v 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 @@ -738,6 +680,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 @@ -746,6 +689,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 @@ -753,10 +697,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) @@ -772,7 +716,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 @@ -789,14 +733,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} @@ -805,11 +752,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 @@ -818,33 +768,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 _ _ False _) = 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 @@ -858,7 +805,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 @@ -875,11 +822,13 @@ 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) + weird_tuplecon (TupleConId _ arity) = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use weird_tuplecon _ = False \end{code} @@ -887,16 +836,15 @@ 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)) @@ -926,22 +874,13 @@ unlocaliseId mod (Id u ty info (WorkerId unwrkr)) Nothing -> Nothing Just xx -> Just (Id u ty info (WorkerId xx)) -unlocaliseId mod (Id u ty info (InstId inst)) +unlocaliseId mod (Id u ty info (InstId name no_ftvs)) = Just (Id u ty info (TopLevId full_name)) -- type might be wrong, but it hardly matters -- at this stage (just before printing C) ToDo where - name = 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 @@ -965,6 +904,7 @@ unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs)) unlocalise_parent mod uniq other_id = unlocaliseId mod other_id -- we're OK otherwise +-} \end{code} CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@: @@ -975,9 +915,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 @@ -987,26 +929,23 @@ applyTypeEnvToId type_env id@(Id u ty info details) \end{code} \begin{code} -apply_to_Id :: (UniType -> UniType) +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 ty details prag info) + = let + new_ty = ty_fn ty + in + Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info) where - apply_to_details (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) @@ -1017,11 +956,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} @@ -1032,6 +966,7 @@ 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) @@ -1043,13 +978,13 @@ applySubstToId subst id@(Id u ty info details) case (apply_to_details s3 new_ty details) of { (s4, new_details) -> (s4, Id u new_ty new_info new_details) }}} where - apply_to_details subst _ (InstId inst) + 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 @@ -1060,77 +995,79 @@ 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 :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING] + +getIdNamePieces show_uniqs id + = get (unsafeGenId2Id id) + where + get (Id u _ details _ _) + = case details of + DataConId n _ _ _ _ _ _ _ -> + case (nameOrigName n) of { (mod, name) -> + if isPreludeDefinedName n then [name] else [mod, name] } -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 n _ -> [snd (nameOrigName n)] - TupleConId a -> [SLIT("Tup") _APPEND_ (_PK_ (show a))] + RecordSelId lbl -> panic "getIdNamePieces:RecordSelId" - ImportedId n -> get_fullname_pieces n - PreludeId n -> get_fullname_pieces n - TopLevId n -> get_fullname_pieces n + 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 + c_bits = if isPreludeDefined c then [c_name] else [c_mod, c_name] - sc_bits= if fromPreludeCore sc + sc_bits= if isPreludeDefined sc then [sc_name] else [sc_mod, sc_name] in [SLIT("sdsel")] ++ c_bits ++ sc_bits }} - ClassOpId clas op -> + MethodSelId 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] + if isPreludeDefined clas + then [op_name] + else [c_mod, c_name, op_name] } } DefaultMethodId clas op _ -> case (getOrigName clas) of { (c_mod, c_name) -> case (getClassOpString op) of { op_name -> - if fromPreludeCore clas + if isPreludeDefined clas then [SLIT("defm"), op_name] else [SLIT("defm"), c_mod, c_name, op_name] }} - DictFunId c ty _ -> + DictFunId c ty _ _ -> case (getOrigName c) of { (c_mod, c_name) -> let - c_bits = if fromPreludeCore c + c_bits = if isPreludeDefined c then [c_name] else [c_mod, c_name] - + ty_bits = getTypeString ty in [SLIT("dfun")] ++ c_bits ++ ty_bits } - - ConstMethodId c ty o _ -> + 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 -> + case (if isPreludeDefined c + then [c_name] + else [c_mod, c_name]) of { c_bits -> [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}} -- if the unspecialised equiv is "top-level", @@ -1138,57 +1075,30 @@ getIdNamePieces show_uniqs (Id u ty info details) -- 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) - ) + get 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 - ) + get unwrkr ++ (if not (toplevelishId unwrkr) + then [showUnique u] + else [SLIT("wrk")]) - InstId inst -> getInstNamePieces show_uniqs inst LocalId n _ -> let local = getLocalName n in - if show_uniqs then [local, showUnique u] else [local] + if show_uniqs then [local, showUnique u] else [local] + InstId n _ -> [getLocalName n, showUnique u] SysLocalId n _ -> [getLocalName n, showUnique u] SpecPragmaId n _ _ -> [getLocalName n, showUnique u] -#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 :: Name -> [FAST_STRING] get_fullname_pieces n - = BIND (getOrigName n) _TO_ (mod, name) -> - if fromPrelude mod + = BIND (nameOrigName n) _TO_ (mod, name) -> + if isPreludeDefinedName n 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} - %************************************************************************ %* * \subsection[Id-type-funs]{Type-related @Id@ functions} @@ -1196,56 +1106,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} -{- 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))) +{-LATER: +getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod +getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod +getInstIdModule other = panic "Id:getInstIdModule" -} \end{code} @@ -1256,29 +1139,36 @@ 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 ty (SuperDictSelId c sc) NoPragmaInfo info +mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info +mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info -mkDictFunId u c ity full_ty from_here info - = Id u full_ty info (DictFunId c ity from_here) +mkDictFunId u c ity full_ty from_here mod info + = Id u full_ty (DictFunId c ity from_here mod) NoPragmaInfo info -mkConstMethodId u c op ity full_ty from_here info - = Id u full_ty info (ConstMethodId c ity op from_here) +mkConstMethodId u c op ity full_ty from_here mod info + = Id u full_ty (ConstMethodId c ity op from_here mod) NoPragmaInfo info -mkWorkerId u unwrkr ty info = Id u ty info (WorkerId unwrkr) +mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info -mkInstId inst - = Id u (getInstUniType inst) noIdInfo (InstId inst) - 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) +mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo + +{-LATER: +getConstMethodId clas op ty + = -- constant-method info is hidden in the IdInfo of + -- the class-op id (as mentioned up above). + let + sel_id = getMethodSelId clas op + in + case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of + Just xx -> xx + Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [ + ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids, + ppr PprDebug sel_id], + ppStr "(This can arise if an interface pragma refers to an instance", + ppStr "but there is no imported interface which *defines* that instance.", + ppStr "The info above, however ugly, should indicate what else you need to import." + ]) -} \end{code} @@ -1289,36 +1179,52 @@ 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) ty (ImportedId n) NoPragmaInfo info +mkPreludeId n ty info = Id (nameUnique n) ty (PreludeId n) NoPragmaInfo info -#ifdef DPH -mkPodId d i = PodId d i -#endif - -updateIdType :: Id -> UniType -> Id +{-LATER: +updateIdType :: Id -> Type -> Id updateIdType (Id u _ info details) ty = Id u 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 ty (SysLocalId (mkLocalName uniq str loc) (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 ty (LocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo --- for an 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)) +-- mkUserId builds a local or top-level Id, depending on the name given +mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b +mkUserId name ty pragma_info + | isLocalName name + = Id (nameUnique name) ty (LocalId name (no_free_tvs ty)) pragma_info noIdInfo + | otherwise + = Id (nameUnique name) ty + (if isLocallyDefinedName name then TopLevId name else ImportedId name) + pragma_info noIdInfo +\end{code} + + +\begin{code} +{-LATER: + +-- for a SpecPragmaId being created by the compiler out of thin air... +mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id +mkSpecPragmaId str uniq ty specid loc + = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty)) --- for new SpecId +-- 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)) @@ -1333,70 +1239,48 @@ mkSameSpecCon ty_maybes unspec@(Id u ty info details) 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)) 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 _ ty details prag info) uniq + = Id uniq 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 -} +selectIdInfoForSpecId :: Id -> IdInfo +selectIdInfoForSpecId unspec + = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) + noIdInfo `addInfo_UF` getIdUnfolding unspec +-} \end{code} %************************************************************************ @@ -1410,25 +1294,19 @@ 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 -> ArityInfo +getIdArity (Id _ _ _ _ id_info) = getInfo id_info -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 addIdArity :: Id -> Int -> Id -addIdArity (Id u ty info details) arity - = Id u ty (info `addInfo` (mkArityInfo arity)) details +addIdArity (Id u ty details pinfo info) arity + = Id u ty details pinfo (info `addInfo` (mkArityInfo arity)) \end{code} %************************************************************************ @@ -1438,66 +1316,75 @@ 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) + -- NB: data_con self-recursion; should be OK as tags are not + -- looked at until late in the game. + data_con + = Id (nameUnique n) + type_of_constructor + (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon) + NoPragmaInfo + datacon_info - -- Note data_con self-recursion; - -- should be OK as tags are not looked at until - -- late in the game. + data_con_tag = position_within fIRST_TAG data_con_family - data_con_family = getTyConDataCons tycon + data_con_family = tyConDataCons tycon - position_within :: Int -> [Id] -> Id -> Int - position_within acc [] con - = panic "mkDataCon: con not found in family" + position_within :: Int -> [Id] -> Int - position_within acc (c:cs) con - = if c `eqId` con then acc else position_within (acc+(1::Int)) cs con + position_within acc (c:cs) + = if c == data_con then acc else position_within (acc+1) cs +#ifdef DEBUG + position_within acc [] + = panic "mkDataCon: con not found in family" +#endif - type_of_constructor = mkSigmaTy 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 -> + BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con -> mkUnfolding EssentialUnfolding -- for data constructors - (foldr CoTyLam lambdized_CoCon tyvars) - BEND BEND + (mkLam tyvars (dict_vars ++ vars) plain_Con) + BEND - 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 getItsUnique tvs) in -- the "context" and "arg_tys" have TyVarTemplates in them, so -- we instantiate those types to have the right TyVars in them -- instead. - BIND (map (instantiateTauTy inst_env) (map ctxt_ty context)) + BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt)) _TO_ inst_dict_tys -> BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys -> @@ -1506,55 +1393,52 @@ mkDataCon k n tyvar_tmpls context args_tys tycon specenv = data_con -- (Mega-Sigh) [ToDo] BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars -> - BIND (splitAt (length context) all_vars) _TO_ (dict_vars, vars) -> + BIND (splitAt (length ctxt) all_vars) _TO_ (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 ty (TupleConId n arity) NoPragmaInfo tuplecon_info where - data_con = Id unique ty tuplecon_info (TupleConId arity) + n = panic "mkTupleCon: its Name (Id)" unique = mkTupleDataConUnique arity - ty = mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys)) + 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` tuplecon_specenv - - tuplecon_specenv - = if arity == 2 then - pcGenerateDataSpecs ty - else - nullSpecEnv +--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 -> + BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con -> mkUnfolding EssentialUnfolding -- data constructors - (foldr CoTyLam lambdized_CoCon tyvars) - BEND BEND + (mkLam tyvars (dict_vars ++ vars) plain_Con) + BEND mk_uf_bits arity = BIND (mkTemplateLocals tyvar_tys) _TO_ vars -> @@ -1562,70 +1446,61 @@ mkTupleCon arity = data_con BEND 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 getItsUnique 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 - -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 -} +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 -getDataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon +dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon +dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon +dataConTyCon (Id _ _ (TupleConId _ a) _ _) = mkTupleTyCon a -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 + tyvar_tys = mkTyVarTys tyvars + +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields +\end{code} + +\begin{code} +mkRecordSelId field_label selector_ty + = Id (nameUnique name) + selector_ty + (RecordSelId field_label) + NoPragmaInfo + noIdInfo + where + name = fieldLabelName field_label -getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _)) +recordSelectorFieldLabel :: Id -> FieldLabel +recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl +\end{code} + +{- LATER +dataConTyCon (Id _ _ _ (SpecId unspec tys _)) + = mkSpecTyCon (dataConTyCon unspec) tys + +dataConSig (Id _ _ _ (SpecId unspec ty_maybes _)) = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon) where - (tyvars, theta_ty, arg_tys, tycon) = getDataConSig unspec + (tyvars, theta_ty, arg_tys, tycon) = dataConSig unspec ty_env = tyvars `zip` ty_maybes @@ -1639,23 +1514,17 @@ getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _)) spec_arg_tys = map (instantiateTauTy spec_env) arg_tys spec_theta_ty = if null theta_ty then [] - else panic "getDataConSig:ThetaTy:SpecDataCon" + else panic "dataConSig: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 -} +-} \end{code} +\begin{pseudocode} @getInstantiatedDataConSig@ takes a constructor and some types to which it is applied; it returns its signature instantiated to these types. \begin{code} -getInstantiatedDataConSig :: +getInstantiatedDataConSig :: DataCon -- The data constructor -- Not a specialised data constructor -> [TauType] -- Types to which applied @@ -1665,77 +1534,20 @@ getInstantiatedDataConSig :: TauType -- Type of result ) -getInstantiatedDataConSig data_con tycon_arg_tys +getInstantiatedDataConSig data_con inst_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 + (tvs, theta, arg_tys, tycon) = dataConSig 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 + inst_env = ASSERT(length tvs == length inst_tys) + tvs `zip` inst_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) + theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ] + cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ] + result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys) in -- Are the first/third results ever used? (theta_tys, cmpnt_tys, result_ty) - -{- 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? - 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} - -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 -} \end{code} Data type declarations are of the form: @@ -1745,9 +1557,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. %************************************************************************ @@ -1772,34 +1584,11 @@ dictionaries, in the even of an overloaded data-constructor---none at present.) \begin{code} -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 -> UnfoldingDetails -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 = ASSERT( @@ -1811,10 +1600,6 @@ addIdUnfolding id@(Id u ty info details) unfold_details _ -> 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 -} \end{code} @@ -1829,25 +1614,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@} @@ -1856,47 +1622,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 ty details prags info) demand_info + = Id u 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 ty details prags info) upd_info + = Id u ty details prags (info `addInfo` upd_info) \end{code} \begin{code} +{- LATER: getIdArgUsageInfo :: Id -> ArgUsageInfo getIdArgUsageInfo (Id u 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 +-} \end{code} \begin{code} +{- LATER: getIdFBTypeInfo :: Id -> FBTypeInfo getIdFBTypeInfo (Id u 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 +-} \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 ty details prags info) spec_info + = Id u ty details prags (info `addInfo` spec_info) +-} \end{code} Strictness: we snaffle the info out of the IdInfo. @@ -1904,12 +1676,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 ty details prags info) strict_info + = Id u ty details prags (info `addInfo` strict_info) \end{code} %************************************************************************ @@ -1921,33 +1693,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 Ord3 (GenId ty) where + cmp = cmpId -instance Eq Id where +instance Eq (GenId ty) where a == b = case cmpId a b of { EQ_ -> True; _ -> False } a /= b = case cmpId a b of { EQ_ -> False; _ -> True } -instance Ord Id where +instance Ord (GenId ty) where a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False } a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False } a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True } a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True } -#ifdef __GLASGOW_HASKELL__ _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } -#endif \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_ @@ -1962,18 +1731,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} %************************************************************************ @@ -1983,7 +1746,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 @@ -1996,28 +1763,20 @@ 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. -\begin{code} -is_prelude_core_ty :: UniType -> Bool - -is_prelude_core_ty inst_ty - = case getUniDataTyCon_maybe inst_ty of - Just (tycon,_,_) -> fromPreludeCore tycon - Nothing -> panic "Id: is_prelude_core_ty" +-} \end{code} Default printing code (not used for interfaces): \begin{code} -pprId :: PprStyle -> Id -> Pretty +pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty pprId other_sty id = let @@ -2031,108 +1790,73 @@ pprId other_sty id 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 + PprForC -> for_code + PprForAsm _ _ -> for_code + PprInterface -> ppr other_sty occur_name + PprForUser -> ppr other_sty occur_name + PprUnfolding -> qualified_name pieces PprDebug -> qualified_name pieces PprShowAll -> ppBesides [qualified_name pieces, (ppCat [pp_uniq id, ppPStr SLIT("{-"), - ppr other_sty (getIdUniType id), - ppIdInfo other_sty id True (\x->x) nullIdEnv (getIdInfo id), + ppr other_sty (idType id), + ppIdInfo other_sty (unsafeGenId2Id 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))))) + occur_name = getOccName id `appendRdr` + (if not (isSysLocalId id) + then SLIT("") + else SLIT(".") _APPEND_ (showUnique (idUnique id))) qualified_name pieces = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id) - pp_uniq (Id _ _ _ (PreludeId _)) = ppNil -- No uniq to add - pp_uniq (Id _ _ _ (DataConId _ _ _ _ _ _)) = ppNil -- 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) + pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add + pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = ppNil + pp_uniq (Id _ _ (TupleConId _ _) _ _) = ppNil + pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere + pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil + pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil + pp_uniq (Id _ _ (InstId _ _) _ _) = ppNil + pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (idUnique other_id), ppPStr SLIT("-}")] + + -- print PprDebug Ids with # afterwards if they are of primitive type. + pp_ubxd pretty = pretty + +{- LATER: applying isPrimType restricts type + pp_ubxd pretty = if isPrimType (idType id) then ppBeside pretty (ppChar '#') else pretty +-} + \end{code} \begin{code} -instance NamedThing Id where - getExportFlag (Id _ _ _ details) - = 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) +idUnique (Id u _ _ _ _) = u + +instance Uniquable (GenId ty) where + uniqueOf = idUnique + +instance NamedThing (GenId ty) where + getName this_id@(Id u _ details _ _) = get details where - get (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 _) = n + get (SysLocalId n _) = n + get (SpecPragmaId n _ _)= n + get (ImportedId n) = n + get (PreludeId n) = n + get (TopLevId n) = n + get (InstId n _) = n + get (DataConId n _ _ _ _ _ _ _) = n + get (TupleConId n _) = n + get (RecordSelId l) = getName l +-- get _ = pprPanic "Id.Id.NamedThing.getName:" (pprId PprDebug this_id) + +{- LATER: + get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ??? + (mod, _) -> (mod, getClassOpString op) get (SpecId unspec ty_maybes _) = BIND getOrigName unspec _TO_ (mod, unspec_nm) -> @@ -2155,29 +1879,6 @@ instance NamedThing Id where ) 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, @@ -2187,78 +1888,92 @@ instance NamedThing Id where BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces -> (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) BEND BEND +-} +\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}