X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=ff7deabd8c8d4223d0a67a59e555ccfb0956c6e3;hb=6c381e873e222417d9a67aeec77b9555eca7b7a8;hp=971855ff2d2478fef5e1b67e68a3d4b71e174ec9;hpb=68a1f0233996ed79824d11d946e9801473f6946c;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 971855f..ff7deab 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,36 @@ 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, + getIdPrimRep, getInstIdModule, getMentionedTyConsAndClassesFromId, getDataConTag, getDataConSig, getInstantiatedDataConSig, - getDataConTyCon, -- UNUSED: getDataConFamily, -#ifdef USE_SEMANTIQUE_STRANAL - getDataConDeps, -#endif + + getDataConTyCon, -- PREDICATES - isDataCon, isTupleCon, isNullaryDataCon, + isDataCon, isTupleCon, 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, @@ -74,7 +66,7 @@ module Id ( getIdDemandInfo, addIdDemandInfo, getIdSpecialisation, addIdSpecialisation, getIdStrictness, addIdStrictness, - getIdUnfolding, addIdUnfolding, -- UNUSED? clearIdUnfolding, + getIdUnfolding, addIdUnfolding, getIdUpdateInfo, addIdUpdateInfo, getIdArgUsageInfo, addIdArgUsageInfo, getIdFBTypeInfo, addIdFBTypeInfo, @@ -86,78 +78,70 @@ 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 NameLoop -- 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 Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp ) +import IdInfo +import Maybes ( maybeToBool ) +import NameTypes ( mkShortName, fromPrelude, FullName, ShortName ) 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 Outputable ( isAvarop, isAconop, getLocalName, + isExported, ExportFlag(..) ) +import PragmaInfo ( PragmaInfo(..) ) +import PrelMods ( pRELUDE_BUILTIN ) +import PprType ( GenType, GenTyVar, + getTypeString, typeMaybeString, specMaybeTysSuffix ) +import PprStyle +import Pretty +import SrcLoc ( mkBuiltinSrcLoc ) +import TyCon ( TyCon, mkTupleTyCon, getTyConDataCons ) +import Type ( mkSigmaTy, mkTyVarTy, mkFunTys, mkDictTy, + applyTyCon, isPrimType, instantiateTy, + GenType, ThetaType(..), TauType(..), Type(..) ) +import TyVar ( GenTyVar, alphaTyVars ) import UniqFM -import UniqSet -import Unique -import Util -#ifdef DPH -IMPORT_Trace -import PodizeCore ( podizeTemplateExpr ) -import PodInfoTree ( infoTypeNumToMask ) -#endif {- Data Parallel Haskell -} +import UniqSet ( UniqSet(..) ) +import Unique ( Unique, mkTupleDataConUnique, pprUnique, showUnique ) +import Util ( mapAccumL, nOfThem, 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 @@ -170,8 +154,8 @@ data IdDetails Bool -- as for LocalId | SpecPragmaId ShortName -- introduced by the compiler - (Maybe SpecInfo)-- for explicit specid in pragma - Bool -- as for LocalId + (Maybe Id) -- for explicit specid in pragma + Bool -- as for LocalId ---------------- Global values @@ -189,47 +173,81 @@ data IdDetails | 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)]" + [StrictnessMark] -- Strict args; length = arity - -- 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 -} - ---------------- Things to do with overloading | SuperDictSelId -- Selector for superclass dictionary 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 + FAST_STRING -- module where instance came from + + -- 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 + FAST_STRING -- module where instance came from + + | InstId ShortName -- 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 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 @@ -251,21 +269,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 +300,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 +315,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 +324,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. %---------------------------------------------------------------------- @@ -387,7 +358,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 +408,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 +423,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,44 +430,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 @@ -510,154 +471,106 @@ 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 (DataConId _ _ _ _ _ _ _) = True + chk (TupleConId _) = 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 + 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 (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 (DataConId _ _ _ _ _ _ _) = True + chk (TupleConId _) = 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 _) = False -- these are local + chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr + chk (InstId _) = False -- these are local 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_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) = panic "isBottomingId not implemented" + -- LATER: 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 (getItsUnique v) -- ubiquitous Ids with special syntax: else if v == nilDataCon then @@ -668,7 +581,7 @@ pprIdInUnfolding in_scopes 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 @@ -677,12 +590,12 @@ pprIdInUnfolding in_scopes v -- these ones' exportedness checked later... TopLevId _ -> pp_full_name - DataConId _ _ _ _ _ _ -> pp_full_name + DataConId _ _ _ _ _ _ _ -> pp_full_name -- 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] @@ -731,8 +644,8 @@ pprIdInUnfolding in_scopes v 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 +654,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 +663,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 +671,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 +690,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 +707,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 +726,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,12 +742,12 @@ 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. @@ -835,7 +756,7 @@ unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ naughty_DictFunId dfun --) -unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) +unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _) = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) ( naughty_DictFunId dfun -- similar deal... --) @@ -848,6 +769,7 @@ naughty_DictFunId :: IdDetails -> Bool 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 @@ -861,7 +783,10 @@ compiling the prelude, the compiler may not recognise that as true. \begin{code} externallyVisibleId :: Id -> Bool -externallyVisibleId id@(Id _ _ _ details) +externallyVisibleId id = panic "Id.externallyVisibleId" +{-LATER: + +externallyVisibleId id@(Id _ _ details _ _) = if isLocallyDefined id then toplevelishId id && isExported id && not (weird_datacon details) else @@ -878,28 +803,32 @@ externallyVisibleId id@(Id _ _ _ details) -- of WeirdLocalType; but we need to know this when asked if -- "Mumble" is externally visible... - weird_datacon (DataConId _ _ _ _ _ tycon) + weird_datacon (DataConId _ _ _ _ _ _ tycon) = maybeToBool (maybePurelyLocalTyCon tycon) weird_datacon not_a_datacon_therefore_not_weird = False weird_tuplecon (TupleConId arity) = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use weird_tuplecon _ = False +-} \end{code} \begin{code} +{-LATER: idWantsToBeINLINEd :: Id -> Bool idWantsToBeINLINEd id = case (getIdUnfolding id) of IWantToBeINLINEd _ -> True _ -> 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)) @@ -929,22 +858,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)) = 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 @@ -968,6 +888,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@: @@ -978,6 +899,7 @@ The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the former ``should be'' the usual crunch point. \begin{code} +{-LATER: applyTypeEnvToId :: TypeEnv -> Id -> Id applyTypeEnvToId type_env id@(Id u ty info details) @@ -987,10 +909,12 @@ applyTypeEnvToId type_env id@(Id u ty info details) = apply_to_Id ( \ ty -> applyTypeEnvToTy type_env ty ) id +-} \end{code} \begin{code} -apply_to_Id :: (UniType -> UniType) +{-LATER: +apply_to_Id :: (Type -> Type) -> Id -> Id @@ -1020,12 +944,8 @@ 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} Sadly, I don't think the one using the magic typechecker substitution @@ -1035,6 +955,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) @@ -1052,7 +973,7 @@ applySubstToId subst id@(Id u ty info details) 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,30 +984,29 @@ 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 _ _ _ _ _ -> +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 (getOrigName n) of { (mod, name) -> if fromPrelude mod then [name] else [mod, name] } - TupleConId a -> [SLIT("Tup") _APPEND_ (_PK_ (show a))] + TupleConId 0 -> [SLIT("()")] + TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )] - 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) -> @@ -1102,7 +1022,7 @@ getIdNamePieces show_uniqs (Id u ty info details) 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] @@ -1121,7 +1041,7 @@ getIdNamePieces show_uniqs (Id u ty info details) c_bits = if fromPreludeCore c then [c_name] else [c_mod, c_name] - + ty_bits = getTypeString ty in [SLIT("dfun")] ++ c_bits ++ ty_bits } @@ -1141,31 +1061,21 @@ 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 n = BIND (getOrigName n) _TO_ (mod, name) -> @@ -1175,23 +1085,6 @@ get_fullname_pieces n 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} @@ -1199,63 +1092,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) +--getIdPrimRep i = primRepFromType (idType i) \end{code} \begin{code} +{-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 +1125,37 @@ 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 modname info - = Id u full_ty info (DictFunId c ity from_here modname) + = Id u full_ty (DictFunId c ity from_here modname) NoPragmaInfo info mkConstMethodId u c op ity full_ty from_here modname info - = Id u full_ty info (ConstMethodId c ity op from_here modname) + = Id u full_ty (ConstMethodId c ity op from_here modname) 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) 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 -> error (ppShow 80 (ppAboves [ + ppCat [ppStr "ERROR: getConstMethodId:", ppr PprDebug op, + 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,36 +1166,48 @@ 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) - -#ifdef DPH -mkPodId d i = PodId d i -#endif +mkImported u n ty info = Id u ty (ImportedId n) NoPragmaInfo info +mkPreludeId u n ty info = Id u ty (PreludeId n) NoPragmaInfo info -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) +no_free_tvs ty = panic "Id:no_free_tvs" -- null (extractTyVarsFromTy 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 -> ty -> SrcLoc -> GenId ty mkSysLocal str uniq ty loc - = Id uniq ty noIdInfo (SysLocalId (mkShortName str loc) (no_free_tvs ty)) + = Id uniq ty (SysLocalId (mkShortName 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 (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo + +-- mkUserId builds a local or top-level Id, depending on the name given +mkUserId :: Name -> ty -> PragmaInfo -> GenId ty +mkUserId (Short uniq short) ty pragma_info + = Id uniq ty (LocalId short (no_free_tvs ty)) pragma_info noIdInfo +mkUserId (ValName uniq full) ty pragma_info + = Id uniq ty + (if isLocallyDefined full then TopLevId full else ImportedId full) + 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 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)) @@ -1346,13 +1225,6 @@ mkSameSpecCon ty_maybes unspec@(Id u ty info details) -- 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)) @@ -1365,53 +1237,40 @@ localiseId id@(Id u ty info details) 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 -} + = Id uniq ty info new_details +-} \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] +{-LATER: +mkTemplateLocals :: [Type] -> [Id] mkTemplateLocals tys = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc) (getBuiltinUniques (length tys)) tys +-} \end{code} \begin{code} -getIdInfo :: Id -> IdInfo - -getIdInfo (Id _ _ info _) = info +getIdInfo :: GenId ty -> IdInfo +getPragmaInfo :: GenId ty -> PragmaInfo -#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} %************************************************************************ @@ -1425,25 +1284,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 _ _ id_info _) = getInfo id_info +getIdArity :: Id -> ArityInfo +getIdArity (Id _ _ _ _ id_info) = getInfo id_info -getDataConArity id@(Id _ _ id_info _) +getDataConArity :: DataCon -> Int +getDataConArity id@(Id _ _ _ _ id_info) = ASSERT(isDataCon id) case (arityMaybe (getInfo id_info)) of Nothing -> pprPanic "getDataConArity:Nothing:" (ppr 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} %************************************************************************ @@ -1453,66 +1306,76 @@ 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 :: Unique{-DataConKey-} + -> FullName + -> [StrictnessMark] + -> [TyVar] -> ThetaType -> [TauType] -> TyCon +--ToDo: -> SpecEnv + -> Id + -- can get the tag and all the pieces of the type from the Type + +mkDataCon k n stricts 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 k + type_of_constructor + (DataConId n data_con_tag stricts 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 = getTyConDataCons 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 (map mkTyVarTy 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 + (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon tyvar_tys = map mkTyVarTy 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 -> @@ -1521,34 +1384,38 @@ 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 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)) + ty = mkSigmaTy tyvars [] + (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys)) tycon = mkTupleTyCon arity tyvars = take arity alphaTyVars - tyvar_tys = map mkTyVarTemplateTy tyvars + tyvar_tys = map mkTyVarTy 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... @@ -1556,14 +1423,12 @@ mkTupleCon arity = data_con (tyvars, dict_vars, vars) = mk_uf_bits arity tyvar_tys = map mkTyVarTy 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 -> @@ -1571,65 +1436,39 @@ 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 -} +getDataConTag (Id _ _ (DataConId _ tag _ _ _ _ _) _ _) = tag +getDataConTag (Id _ _ (TupleConId _) _ _) = fIRST_TAG +getDataConTag (Id _ _ (SpecId unspec _ _) _ _) = getDataConTag unspec getDataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon +getDataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon +getDataConTyCon (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) +getDataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon) -- will panic if not a DataCon -getDataConSig (Id _ _ _ (DataConId _ _ tyvars theta_ty arg_tys tycon)) +getDataConSig (Id _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _) = (tyvars, theta_ty, arg_tys, tycon) -getDataConSig (Id _ _ _ (TupleConId arity)) +getDataConSig (Id _ _ (TupleConId arity) _ _) = (tyvars, [], tyvar_tys, mkTupleTyCon arity) where tyvars = take arity alphaTyVars - tyvar_tys = map mkTyVarTemplateTy tyvars + tyvar_tys = map mkTyVarTy tyvars +\end{code} + +{- LATER +getDataConTyCon (Id _ _ _ (SpecId unspec tys _)) + = mkSpecTyCon (getDataConTyCon unspec) tys getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _)) = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon) @@ -1650,21 +1489,15 @@ getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _)) 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 -} +-} \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 @@ -1674,77 +1507,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) = 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 + 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: @@ -1754,9 +1530,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,34 +1557,11 @@ 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 = ASSERT( @@ -1820,10 +1573,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} @@ -1838,25 +1587,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 +1595,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. @@ -1913,12 +1649,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} %************************************************************************ @@ -1930,35 +1666,33 @@ 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 +instance Ord3 (GenId ty) where + cmp = cmpId -eqId a b = case cmpId a b of { EQ_ -> True; _ -> False } - -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} +{-LATER: cmpId_withSpecDataCon :: Id -> Id -> TAG_ cmpId_withSpecDataCon id1 id2 @@ -1982,7 +1716,7 @@ cmpEqDataCon (Id _ _ _ (SpecId _ _ _)) unspec2 cmpEqDataCon unspec1 unspec2 = EQ_ - +-} \end{code} %************************************************************************ @@ -1992,7 +1726,7 @@ cmpEqDataCon unspec1 unspec2 %************************************************************************ \begin{code} -instance Outputable Id where +instance Outputable ty => Outputable (GenId ty) where ppr sty id = pprId sty id showId :: PprStyle -> Id -> String @@ -2005,90 +1739,102 @@ 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 :: Type -> Bool is_prelude_core_ty inst_ty - = case getUniDataTyCon_maybe inst_ty of + = panic "Id.is_prelude_core_ty" +{- LATER + = case maybeDataTyCon 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 pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id - for_code - = let + for_code = panic "pprId: 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 + PprForC -> for_code + PprForAsm _ _ -> for_code + PprInterface -> ppPStr occur_name PprForUser -> ppPStr occur_name - PprUnfolding _ -> qualified_name pieces + 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))))) + else "." ++ (_UNPK_ (showUnique (getItsUnique 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 (getItsUnique 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) +instance NamedThing (GenId ty) where + getExportFlag (Id _ _ details _ _) = get details where - get (DataConId _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName + 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 (MethodSelId 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 @@ -2098,21 +1844,17 @@ instance NamedThing Id where 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) + isLocallyDefined this_id@(Id _ _ details _ _) = get details where - get (DataConId _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName + 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 (MethodSelId 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 @@ -2126,23 +1868,21 @@ instance NamedThing Id where 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) + 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 (DataConId n _ _ _ _ _ _) = getOrigName n + get (TupleConId 0) = (pRELUDE_BUILTIN, SLIT("()")) + get (TupleConId a) = (pRELUDE_BUILTIN, _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )) + 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 (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ??? + (mod, _) -> (mod, getClassOpString op) +{- LATER: get (SpecId unspec ty_maybes _) = BIND getOrigName unspec _TO_ (mod, unspec_nm) -> BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix -> @@ -2163,29 +1903,16 @@ instance NamedThing Id where 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 (InstId n) = (panic "NamedThing.Id.getOrigName (LocalId)", + getLocalName n) + 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) get other_details -- the remaining internally-generated flavours of @@ -2197,77 +1924,122 @@ instance NamedThing Id where (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) BEND BEND - getOccurrenceName this_id@(Id _ _ _ details) + getOccurrenceName this_id@(Id _ _ details _ _) = get details where - get (DataConId n _ _ _ _ _) = getOccurrenceName n - get (TupleConId a) = SLIT("Tup") _APPEND_ (_PK_ (show a)) + get (DataConId n _ _ _ _ _ _) = getOccurrenceName n + get (TupleConId 0) = SLIT("()") + get (TupleConId a) = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" ) 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 (MethodSelId _ op) = getClassOpString op get _ = snd (getOrigName this_id) getInformingModules id = panic "getInformingModule:Id" - getSrcLoc (Id _ _ id_info details) + getSrcLoc (Id _ _ details _ id_info) = get details where - get (DataConId n _ _ _ _ _) = getSrcLoc n + 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 (MethodSelId c _) = getSrcLoc c get (SpecId unspec _ _) = getSrcLoc unspec get (WorkerId unwrkr) = getSrcLoc unwrkr - get (InstId i) = let (loc,_) = getInstOrigin i - in loc + get (InstId n) = getSrcLoc n 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 + getItsUnique (Id u _ _ _ _) = u - fromPreludeCore (Id _ _ _ details) + fromPreludeCore (Id _ _ details _ _) = get details where - get (DataConId _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName + 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 (MethodSelId 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 (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 \end{code} -Reason for @getTheUnique@: The code generator doesn't carry a +Reason for @getItsUnique@: The code generator doesn't carry a @UniqueSupply@, so it wants to use 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 = singletonUFM + +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} + +\begin{code} +type GenIdSet ty = UniqSet (GenId ty) +type IdSet = UniqSet (GenId Type) +\end{code}