2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[Id]{@Ids@: Value and constructor identifiers}
7 #include "HsVersions.h"
10 GenId, Id(..), -- Abstract
11 StrictnessMark(..), -- An enumaration
12 ConTag(..), DictVar(..), DictFun(..), DataCon(..),
15 mkSysLocal, mkUserLocal,
17 mkSpecId, mkSameSpecCon,
18 selectIdInfoForSpecId,
20 mkImported, mkPreludeId,
21 mkDataCon, mkTupleCon,
23 mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
24 mkConstMethodId, getConstMethodId,
27 mkId, mkDictFunId, mkInstId,
33 getIdInfo, replaceIdInfo,
35 idPrimRep, getInstIdModule,
36 getMentionedTyConsAndClassesFromId,
38 dataConTag, dataConStrictMarks,
39 dataConSig, dataConArgTys,
40 dataConTyCon, dataConArity,
43 recordSelectorFieldLabel,
46 isDataCon, isTupleCon,
47 isSpecId_maybe, isSpecPragmaId_maybe,
48 toplevelishId, externallyVisibleId,
49 isTopLevId, isWorkerId, isWrapperId,
50 isImportedId, isSysLocalId,
52 isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
55 isConstMethodId_maybe,
56 cmpId_withSpecDataCon,
59 unfoldingUnfriendlyId, -- ToDo: rm, eventually
61 -- dataConMentionsNonPreludeTyCon,
64 applySubstToId, applyTypeEnvToId,
65 -- not exported: apply_to_Id, -- please don't use this, generally
67 -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
68 getIdArity, addIdArity,
69 getIdDemandInfo, addIdDemandInfo,
70 getIdSpecialisation, addIdSpecialisation,
71 getIdStrictness, addIdStrictness,
72 getIdUnfolding, addIdUnfolding,
73 getIdUpdateInfo, addIdUpdateInfo,
74 getIdArgUsageInfo, addIdArgUsageInfo,
75 getIdFBTypeInfo, addIdFBTypeInfo,
76 -- don't export the types, lest OptIdInfo be dragged in!
86 -- "Environments" keyed off of Ids, and sets of Ids
88 lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
89 growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
90 delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
93 -- and to make the interface self-sufficient...
94 GenIdSet(..), IdSet(..)
98 import IdLoop -- for paranoia checking
99 import TyLoop -- for paranoia checking
102 import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
103 import CStrings ( identToC, cSEP )
105 import Maybes ( maybeToBool )
106 import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
107 isLocallyDefinedName, isPreludeDefinedName,
108 mkTupleDataConName, mkCompoundName, mkCompoundName2,
109 isLexSym, isLexSpecialSym, getLocalName,
110 isLocallyDefined, isPreludeDefined, changeUnique,
111 getOccName, moduleNamePair, origName, nameOf,
112 isExported, ExportFlag(..),
115 import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
116 import PragmaInfo ( PragmaInfo(..) )
117 import PprEnv -- ( NmbrM(..), NmbrEnv(..) )
118 import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
124 import SrcLoc ( mkBuiltinSrcLoc )
125 import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
126 import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
127 applyTyCon, isPrimType, instantiateTy,
128 tyVarsOfType, applyTypeEnvToTy, typePrimRep,
129 GenType, ThetaType(..), TauType(..), Type(..)
131 import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
133 import UniqSet -- practically all of it
134 import Unique ( getBuiltinUniques, pprUnique, showUnique,
136 Unique{-instance Ord3-}
138 import Util ( mapAccumL, nOfThem, zipEqual,
139 panic, panic#, pprPanic, assertPanic
143 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
146 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
147 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
148 strictness). The essential info about different kinds of @Ids@ is
151 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
155 Unique -- Key for fast comparison
157 ty -- Id's type; used all the time;
158 IdDetails -- Stuff about individual kinds of Ids.
159 PragmaInfo -- Properties of this Id requested by programmer
160 -- eg specialise-me, inline-me
161 IdInfo -- Properties of this Id deduced by compiler
165 data StrictnessMark = MarkedStrict | NotMarkedStrict
169 ---------------- Local values
171 = LocalId Bool -- Local name; mentioned by the user
172 -- True <=> no free type vars
174 | SysLocalId Bool -- Local name; made up by the compiler
177 | SpecPragmaId -- Local name; introduced by the compiler
178 (Maybe Id) -- for explicit specid in pragma
179 Bool -- as for LocalId
181 ---------------- Global values
183 | ImportedId -- Global name (Imported or Implicit); Id imported from an interface
185 | PreludeId -- Global name (Builtin); Builtin prelude Ids
187 | TopLevId -- Global name (LocalDef); Top-level in the orig source pgm
188 -- (not moved there by transformations).
190 -- a TopLevId's type may contain free type variables, if
191 -- the monomorphism restriction applies.
193 ---------------- Data constructors
196 [StrictnessMark] -- Strict args; length = arity
197 [FieldLabel] -- Field labels for this constructor
199 [TyVar] [(Class,Type)] [Type] TyCon
201 -- forall tyvars . theta_ty =>
202 -- unitype_1 -> ... -> unitype_n -> tycon tyvars
204 | TupleConId Int -- Its arity
206 | RecordSelId FieldLabel
208 ---------------- Things to do with overloading
210 | SuperDictSelId -- Selector for superclass dictionary
211 Class -- The class (input dict)
212 Class -- The superclass (result dict)
214 | MethodSelId Class -- An overloaded class operation, with
215 -- a fully polymorphic type. Its code
216 -- just selects a method from the
217 -- dictionary. The class.
218 ClassOp -- The operation
220 -- NB: The IdInfo for a MethodSelId has all the info about its
221 -- related "constant method Ids", which are just
222 -- specialisations of this general one.
224 | DefaultMethodId -- Default method for a particular class op
225 Class -- same class, <blah-blah> info as MethodSelId
226 ClassOp -- (surprise, surprise)
227 Bool -- True <=> I *know* this default method Id
228 -- is a generated one that just says
229 -- `error "No default method for <op>"'.
232 | DictFunId Class -- A DictFun is uniquely identified
233 Type -- by its class and type; this type has free type vars,
234 -- whose identity is irrelevant. Eg Class = Eq
236 -- The "a" is irrelevant. As it is too painful to
237 -- actually do comparisons that way, we kindly supply
238 -- a Unique for that purpose.
239 (Maybe Module) -- module where instance came from; Nothing => Prelude
242 | ConstMethodId -- A method which depends only on the type of the
243 -- instance, and not on any further dictionaries etc.
244 Class -- Uniquely identified by:
245 Type -- (class, type, classop) triple
247 (Maybe Module) -- module where instance came from; Nothing => Prelude
249 | InstId -- An instance of a dictionary, class operation,
250 -- or overloaded value (Local name)
251 Bool -- as for LocalId
253 | SpecId -- A specialisation of another Id
254 Id -- Id of which this is a specialisation
255 [Maybe Type] -- Types at which it is specialised;
256 -- A "Nothing" says this type ain't relevant.
257 Bool -- True <=> no free type vars; it's not enough
258 -- to know about the unspec version, because
259 -- we may specialise to a type w/ free tyvars
260 -- (i.e., in one of the "Maybe Type" dudes).
262 | WorkerId -- A "worker" for some other Id
263 Id -- Id for which this is a worker
271 DictFunIds are generated from instance decls.
276 instance Foo a => Foo [a] where
279 generates the dict fun id decl
281 dfun.Foo.[*] = \d -> ...
283 The dfun id is uniquely named by the (class, type) pair. Notice, it
284 isn't a (class,tycon) pair any more, because we may get manually or
285 automatically generated specialisations of the instance decl:
287 instance Foo [Int] where
294 The type variables in the name are irrelevant; we print them as stars.
297 Constant method ids are generated from instance decls where
298 there is no context; that is, no dictionaries are needed to
299 construct the method. Example
301 instance Foo Int where
304 Then we get a constant method
309 It is possible, albeit unusual, to have a constant method
310 for an instance decl which has type vars:
312 instance Foo [a] where
316 We get the constant method
320 So a constant method is identified by a class/op/type triple.
321 The type variables in the type are irrelevant.
324 For Ids whose names must be known/deducible in other modules, we have
325 to conjure up their worker's names (and their worker's worker's
326 names... etc) in a known systematic way.
329 %************************************************************************
331 \subsection[Id-documentation]{Documentation}
333 %************************************************************************
337 The @Id@ datatype describes {\em values}. The basic things we want to
338 know: (1)~a value's {\em type} (@idType@ is a very common
339 operation in the compiler); and (2)~what ``flavour'' of value it might
340 be---for example, it can be terribly useful to know that a value is a
344 %----------------------------------------------------------------------
345 \item[@DataConId@:] For the data constructors declared by a @data@
346 declaration. Their type is kept in {\em two} forms---as a regular
347 @Type@ (in the usual place), and also in its constituent pieces (in
348 the ``details''). We are frequently interested in those pieces.
350 %----------------------------------------------------------------------
351 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
352 the infinite family of tuples.
354 %----------------------------------------------------------------------
355 \item[@ImportedId@:] These are values defined outside this module.
356 {\em Everything} we want to know about them must be stored here (or in
359 %----------------------------------------------------------------------
360 \item[@PreludeId@:] ToDo
362 %----------------------------------------------------------------------
363 \item[@TopLevId@:] These are values defined at the top-level in this
364 module; i.e., those which {\em might} be exported (hence, a
365 @Name@). It does {\em not} include those which are moved to the
366 top-level through program transformations.
368 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
369 Theoretically, they could be floated inwards, but there's no known
370 advantage in doing so. This way, we can keep them with the same
371 @Unique@ throughout (no cloning), and, in general, we don't have to be
372 so paranoid about them.
374 In particular, we had the following problem generating an interface:
375 We have to ``stitch together'' info (1)~from the typechecker-produced
376 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
377 what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change}
378 between (1) and (2), you're sunk!
380 %----------------------------------------------------------------------
381 \item[@MethodSelId@:] A selector from a dictionary; it may select either
382 a method or a dictionary for one of the class's superclasses.
384 %----------------------------------------------------------------------
387 @mkDictFunId [a,b..] theta C T@ is the function derived from the
390 instance theta => C (T a b ..) where
393 It builds function @Id@ which maps dictionaries for theta,
394 to a dictionary for C (T a b ..).
396 *Note* that with the ``Mark Jones optimisation'', the theta may
397 include dictionaries for the immediate superclasses of C at the type
400 %----------------------------------------------------------------------
403 %----------------------------------------------------------------------
406 %----------------------------------------------------------------------
409 %----------------------------------------------------------------------
410 \item[@LocalId@:] A purely-local value, e.g., a function argument,
411 something defined in a @where@ clauses, ... --- but which appears in
412 the original program text.
414 %----------------------------------------------------------------------
415 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
416 the original program text; these are introduced by the compiler in
419 %----------------------------------------------------------------------
420 \item[@SpecPragmaId@:] Introduced by the compiler to record
421 Specialisation pragmas. It is dead code which MUST NOT be removed
422 before specialisation.
427 %----------------------------------------------------------------------
430 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
431 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
435 They have no free type variables, so if you are making a
436 type-variable substitution you don't need to look inside them.
438 They are constants, so they are not free variables. (When the STG
439 machine makes a closure, it puts all the free variables in the
440 closure; the above are not required.)
442 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
443 properties, but they may not.
446 %************************************************************************
448 \subsection[Id-general-funs]{General @Id@-related functions}
450 %************************************************************************
453 unsafeGenId2Id :: GenId ty -> Id
454 unsafeGenId2Id (Id u n ty d p i) = Id u n (panic "unsafeGenId2Id:ty") d p i
456 isDataCon id = is_data (unsafeGenId2Id id)
458 is_data (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
459 is_data (Id _ _ _ (TupleConId _) _ _) = True
460 is_data (Id _ _ _ (SpecId unspec _ _) _ _) = is_data unspec
461 is_data other = False
464 isTupleCon id = is_tuple (unsafeGenId2Id id)
466 is_tuple (Id _ _ _ (TupleConId _) _ _) = True
467 is_tuple (Id _ _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
468 is_tuple other = False
471 isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _)
472 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
473 Just (unspec, ty_maybes)
474 isSpecId_maybe other_id
477 isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId specid _) _ _)
479 isSpecPragmaId_maybe other_id
484 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a nested
485 @let(rec)@ (returns @False@), or whether it is {\em sure} to be
486 defined at top level (returns @True@). This is used to decide whether
487 the @Id@ is a candidate free variable. NB: you are only {\em sure}
488 about something if it returns @True@!
491 toplevelishId :: Id -> Bool
492 idHasNoFreeTyVars :: Id -> Bool
494 toplevelishId (Id _ _ _ details _ _)
497 chk (DataConId _ _ _ _ _ _ _) = True
498 chk (TupleConId _) = True
499 chk (RecordSelId _) = True
500 chk ImportedId = True
502 chk TopLevId = True -- NB: see notes
503 chk (SuperDictSelId _ _) = True
504 chk (MethodSelId _ _) = True
505 chk (DefaultMethodId _ _ _) = True
506 chk (DictFunId _ _ _) = True
507 chk (ConstMethodId _ _ _ _) = True
508 chk (SpecId unspec _ _) = toplevelishId unspec
509 -- depends what the unspecialised thing is
510 chk (WorkerId unwrkr) = toplevelishId unwrkr
511 chk (InstId _) = False -- these are local
512 chk (LocalId _) = False
513 chk (SysLocalId _) = False
514 chk (SpecPragmaId _ _) = False
516 idHasNoFreeTyVars (Id _ _ _ details _ info)
519 chk (DataConId _ _ _ _ _ _ _) = True
520 chk (TupleConId _) = True
521 chk (RecordSelId _) = True
522 chk ImportedId = True
525 chk (SuperDictSelId _ _) = True
526 chk (MethodSelId _ _) = True
527 chk (DefaultMethodId _ _ _) = True
528 chk (DictFunId _ _ _) = True
529 chk (ConstMethodId _ _ _ _) = True
530 chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
531 chk (SpecId _ _ no_free_tvs) = no_free_tvs
532 chk (InstId no_free_tvs) = no_free_tvs
533 chk (LocalId no_free_tvs) = no_free_tvs
534 chk (SysLocalId no_free_tvs) = no_free_tvs
535 chk (SpecPragmaId _ no_free_tvs) = no_free_tvs
539 isTopLevId (Id _ _ _ TopLevId _ _) = True
540 isTopLevId other = False
542 isImportedId (Id _ _ _ ImportedId _ _) = True
543 isImportedId other = False
545 isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
547 isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True
548 isSysLocalId other = False
550 isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True
551 isSpecPragmaId other = False
553 isMethodSelId (Id _ _ _ (MethodSelId _ _) _ _) = True
554 isMethodSelId _ = False
556 isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
557 isDefaultMethodId other = False
559 isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _)
560 = Just (cls, clsop, err)
561 isDefaultMethodId_maybe other = Nothing
563 isDictFunId (Id _ _ _ (DictFunId _ _ _) _ _) = True
564 isDictFunId other = False
566 isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True
567 isConstMethodId other = False
569 isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _) _ _)
570 = Just (cls, ty, clsop)
571 isConstMethodId_maybe other = Nothing
573 isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
574 isSuperDictSelId_maybe other_id = Nothing
576 isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
577 isWorkerId other = False
580 isWrapperId id = workerExists (getIdStrictness id)
586 pprIdInUnfolding :: IdSet -> Id -> Pretty
588 pprIdInUnfolding in_scopes v
593 if v `elementOfUniqSet` in_scopes then
594 pprUnique (idUnique v)
596 -- ubiquitous Ids with special syntax:
597 else if v == nilDataCon then
599 else if isTupleCon v then
600 ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
602 -- ones to think about:
605 (Id _ _ _ v_details _ _) = v
608 -- these ones must have been exported by their original module
609 ImportedId -> pp_full_name
610 PreludeId -> pp_full_name
612 -- these ones' exportedness checked later...
613 TopLevId -> pp_full_name
614 DataConId _ _ _ _ _ _ _ -> pp_full_name
616 RecordSelId lbl -> ppr sty lbl
618 -- class-ish things: class already recorded as "mentioned"
620 -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
622 -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
623 DefaultMethodId c o _
624 -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
626 -- instance-ish things: should we try to figure out
627 -- *exactly* which extra instances have to be exported? (ToDo)
629 -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
630 ConstMethodId c t o _
631 -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
633 -- specialisations and workers
634 SpecId unspec ty_maybes _
636 pp = pprIdInUnfolding in_scopes unspec
638 ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
639 ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
644 pp = pprIdInUnfolding in_scopes unwrkr
646 ppBeside (ppPStr SLIT("_WRKR_ ")) pp
648 -- anything else? we're nae interested
649 other_id -> panic "pprIdInUnfolding:mystery Id"
651 ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
655 (m_str, n_str) = moduleNamePair v
658 if isLexSym n_str && not (isLexSpecialSym n_str) then
659 ppBesides [ppLparen, ppPStr n_str, ppRparen]
663 if isPreludeDefined v then
666 ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
668 pp_class :: Class -> Pretty
669 pp_class_op :: ClassOp -> Pretty
670 pp_type :: Type -> Pretty
671 pp_ty_maybe :: Maybe Type -> Pretty
673 pp_class clas = ppr ppr_Unfolding clas
674 pp_class_op op = ppr ppr_Unfolding op
676 pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
678 pp_ty_maybe Nothing = ppPStr SLIT("_N_")
679 pp_ty_maybe (Just t) = pp_type t
683 @whatsMentionedInId@ ferrets out the types/classes/instances on which
684 this @Id@ depends. If this Id is to appear in an interface, then
685 those entities had Jolly Well be in scope. Someone else up the
686 call-tree decides that.
691 :: IdSet -- Ids known to be in scope
692 -> Id -- Id being processed
693 -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
695 whatsMentionedInId in_scopes v
700 = getMentionedTyConsAndClassesFromType v_ty
702 result0 id_bag = (id_bag, tycons, clss)
705 = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
706 tcs `unionBags` tycons,
710 if v `elementOfUniqSet` in_scopes then
711 result0 emptyBag -- v not added to "mentioned"
713 -- ones to think about:
716 (Id _ _ _ v_details _ _) = v
719 -- specialisations and workers
720 SpecId unspec ty_maybes _
722 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
724 result1 ids2 tcs2 cs2
728 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
730 result1 ids2 tcs2 cs2
732 anything_else -> result0 (unitBag v) -- v is added to "mentioned"
736 Tell them who my wrapper function is.
739 myWrapperMaybe :: Id -> Maybe Id
741 myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
742 myWrapperMaybe other_id = Nothing
747 unfoldingUnfriendlyId -- return True iff it is definitely a bad
748 :: Id -- idea to export an unfolding that
749 -> Bool -- mentions this Id. Reason: it cannot
750 -- possibly be seen in another module.
752 unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
755 unfoldingUnfriendlyId id
756 | not (externallyVisibleId id) -- that settles that...
759 unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper) _ _)
760 = class_thing wrapper
762 -- "class thing": If we're going to use this worker Id in
763 -- an interface, we *have* to be able to untangle the wrapper's
764 -- strictness when reading it back in. At the moment, this
765 -- is not always possible: in precisely those cases where
766 -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
768 class_thing (Id _ _ _ (SuperDictSelId _ _) _ _) = True
769 class_thing (Id _ _ _ (MethodSelId _ _) _ _) = True
770 class_thing (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
771 class_thing other = False
773 unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _) _ _)
774 -- a SPEC of a DictFunId can end up w/ gratuitous
775 -- TyVar(Templates) in the i/face; only a problem
776 -- if -fshow-pragma-name-errs; but we can do without the pain.
777 -- A HACK in any case (WDP 94/05/02)
778 = naughty_DictFunId dfun
780 unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _) _ _)
781 = naughty_DictFunId dfun -- similar deal...
783 unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
785 naughty_DictFunId :: IdDetails -> Bool
786 -- True <=> has a TyVar(Template) in the "type" part of its "name"
788 naughty_DictFunId (DictFunId _ _ _) = panic "False" -- came from outside; must be OK
789 naughty_DictFunId (DictFunId _ ty _)
790 = not (isGroundTy ty)
794 @externallyVisibleId@: is it true that another module might be
795 able to ``see'' this Id?
797 We need the @toplevelishId@ check as well as @isExported@ for when we
798 compile instance declarations in the prelude. @DictFunIds@ are
799 ``exported'' if either their class or tycon is exported, but, in
800 compiling the prelude, the compiler may not recognise that as true.
803 externallyVisibleId :: Id -> Bool
805 externallyVisibleId id@(Id _ _ _ details _ _)
806 = if isLocallyDefined id then
807 toplevelishId id && isExported id && not (weird_datacon details)
809 not (weird_tuplecon details)
810 -- if visible here, it must be visible elsewhere, too.
812 -- If it's a DataCon, it's not enough to know it (meaning
813 -- its TyCon) is exported; we need to know that it might
814 -- be visible outside. Consider:
816 -- data Foo a = Mumble | BigFoo a WeirdLocalType
818 -- We can't tell the outside world *anything* about Foo, because
819 -- of WeirdLocalType; but we need to know this when asked if
820 -- "Mumble" is externally visible...
823 weird_datacon (DataConId _ _ _ _ _ _ tycon)
824 = maybeToBool (maybePurelyLocalTyCon tycon)
826 weird_datacon not_a_datacon_therefore_not_weird = False
828 weird_tuplecon (TupleConId arity)
829 = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
830 weird_tuplecon _ = False
834 idWantsToBeINLINEd :: Id -> Bool
836 idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
837 idWantsToBeINLINEd _ = False
840 For @unlocaliseId@: See the brief commentary in
841 \tr{simplStg/SimplStg.lhs}.
845 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
847 unlocaliseId mod (Id u fn ty info TopLevId)
848 = Just (Id u (unlocaliseFullName fn) ty info TopLevId)
850 unlocaliseId mod (Id u sn ty info (LocalId no_ftvs))
851 = --false?: ASSERT(no_ftvs)
853 full_name = unlocaliseShortName mod u sn
855 Just (Id u full_name ty info TopLevId)
857 unlocaliseId mod (Id u sn ty info (SysLocalId no_ftvs))
858 = --false?: on PreludeGlaST: ASSERT(no_ftvs)
860 full_name = unlocaliseShortName mod u sn
862 Just (Id u full_name ty info TopLevId)
864 unlocaliseId mod (Id u n ty info (SpecId unspec ty_maybes no_ftvs))
865 = case unlocalise_parent mod u unspec of
867 Just xx -> Just (Id u n ty info (SpecId xx ty_maybes no_ftvs))
869 unlocaliseId mod (Id u n ty info (WorkerId unwrkr))
870 = case unlocalise_parent mod u unwrkr of
872 Just xx -> Just (Id u n ty info (WorkerId xx))
874 unlocaliseId mod (Id u name ty info (InstId no_ftvs))
875 = Just (Id u full_name ty info TopLevId)
876 -- type might be wrong, but it hardly matters
877 -- at this stage (just before printing C) ToDo
879 name = getLocalName name
880 full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
882 unlocaliseId mod other_id = Nothing
885 -- we have to be Very Careful for workers/specs of
888 unlocalise_parent mod uniq (Id _ sn ty info (LocalId no_ftvs))
889 = --false?: ASSERT(no_ftvs)
891 full_name = unlocaliseShortName mod uniq sn
893 Just (Id uniq full_name ty info TopLevId)
895 unlocalise_parent mod uniq (Id _ sn ty info (SysLocalId no_ftvs))
896 = --false?: ASSERT(no_ftvs)
898 full_name = unlocaliseShortName mod uniq sn
900 Just (Id uniq full_name ty info TopLevId)
902 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
903 -- we're OK otherwise
907 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
908 `Top-levelish Ids'' cannot have any free type variables, so applying
909 the type-env cannot have any effect. (NB: checked in CoreLint?)
911 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
912 former ``should be'' the usual crunch point.
915 type TypeEnv = TyVarEnv Type
917 applyTypeEnvToId :: TypeEnv -> Id -> Id
919 applyTypeEnvToId type_env id@(Id _ _ ty _ _ _)
920 | idHasNoFreeTyVars id
923 = apply_to_Id ( \ ty ->
924 applyTypeEnvToTy type_env ty
929 apply_to_Id :: (Type -> Type) -> Id -> Id
931 apply_to_Id ty_fn (Id u n ty details prag info)
935 Id u n new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
937 apply_to_details (SpecId unspec ty_maybes no_ftvs)
939 new_unspec = apply_to_Id ty_fn unspec
940 new_maybes = map apply_to_maybe ty_maybes
942 SpecId new_unspec new_maybes (no_free_tvs ty)
943 -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
945 apply_to_maybe Nothing = Nothing
946 apply_to_maybe (Just ty) = Just (ty_fn ty)
948 apply_to_details (WorkerId unwrkr)
950 new_unwrkr = apply_to_Id ty_fn unwrkr
954 apply_to_details other = other
957 Sadly, I don't think the one using the magic typechecker substitution
958 can be done with @apply_to_Id@. Here we go....
960 Strictness is very important here. We can't leave behind thunks
961 with pointers to the substitution: it {\em must} be single-threaded.
965 applySubstToId :: Subst -> Id -> (Subst, Id)
967 applySubstToId subst id@(Id u n ty info details)
968 -- *cannot* have a "idHasNoFreeTyVars" get-out clause
969 -- because, in the typechecker, we are still
970 -- *concocting* the types.
971 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
972 case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
973 case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
974 (s4, Id u n new_ty new_info new_details) }}}
976 apply_to_details subst _ (InstId inst no_ftvs)
977 = case (applySubstToInst subst inst) of { (s2, new_inst) ->
978 (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
980 apply_to_details subst new_ty (SpecId unspec ty_maybes _)
981 = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
982 case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
983 (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
984 -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
986 apply_to_maybe subst Nothing = (subst, Nothing)
987 apply_to_maybe subst (Just ty)
988 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
991 apply_to_details subst _ (WorkerId unwrkr)
992 = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
993 (s2, WorkerId new_unwrkr) }
995 apply_to_details subst _ other = (subst, other)
999 %************************************************************************
1001 \subsection[Id-type-funs]{Type-related @Id@ functions}
1003 %************************************************************************
1006 idType :: GenId ty -> ty
1008 idType (Id _ _ ty _ _ _) = ty
1013 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1015 getMentionedTyConsAndClassesFromId id
1016 = getMentionedTyConsAndClassesFromType (idType id)
1021 idPrimRep i = typePrimRep (idType i)
1026 getInstIdModule (Id _ _ _ (DictFunId _ _ mod)) = mod
1027 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ mod)) = mod
1028 getInstIdModule other = panic "Id:getInstIdModule"
1032 %************************************************************************
1034 \subsection[Id-overloading]{Functions related to overloading}
1036 %************************************************************************
1039 mkSuperDictSelId u c sc ty info
1040 = Id u n ty (SuperDictSelId c sc) NoPragmaInfo info
1042 cname = getName c -- we get other info out of here
1044 n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname
1046 mkMethodSelId u c op ty info
1047 = Id u n ty (MethodSelId c op) NoPragmaInfo info
1049 cname = getName c -- we get other info out of here
1051 n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname
1053 mkDefaultMethodId u c op gen ty info
1054 = Id u n ty (DefaultMethodId c op gen) NoPragmaInfo info
1056 cname = getName c -- we get other info out of here
1058 n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname
1060 mkDictFunId u c ity full_ty from_here locn mod info
1061 = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info
1063 n = mkCompoundName2 u SLIT("dfun") [origName c] (getTypeString ity) from_here locn
1065 mkConstMethodId u c op ity full_ty from_here locn mod info
1066 = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info
1068 n = mkCompoundName2 u SLIT("const") [origName c, Unqual (classOpString op)] (getTypeString ity) from_here locn
1070 mkWorkerId u unwrkr ty info
1071 = Id u n ty (WorkerId unwrkr) NoPragmaInfo info
1073 unwrkr_name = getName unwrkr
1075 n = mkCompoundName u SLIT("wrk") [origName unwrkr_name] unwrkr_name
1077 mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
1080 getConstMethodId clas op ty
1081 = -- constant-method info is hidden in the IdInfo of
1082 -- the class-op id (as mentioned up above).
1084 sel_id = getMethodSelId clas op
1086 case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1088 Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
1089 ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1090 ppr PprDebug sel_id],
1091 ppStr "(This can arise if an interface pragma refers to an instance",
1092 ppStr "but there is no imported interface which *defines* that instance.",
1093 ppStr "The info above, however ugly, should indicate what else you need to import."
1098 %************************************************************************
1100 \subsection[local-funs]{@LocalId@-related functions}
1102 %************************************************************************
1105 mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
1106 mkPreludeId n ty info = Id (nameUnique n) n ty PreludeId NoPragmaInfo info
1109 updateIdType :: Id -> Type -> Id
1110 updateIdType (Id u n _ info details) ty = Id u n ty info details
1115 type MyTy a b = GenType (GenTyVar a) b
1116 type MyId a b = GenId (MyTy a b)
1118 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1120 -- SysLocal: for an Id being created by the compiler out of thin air...
1121 -- UserLocal: an Id with a name the user might recognize...
1122 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1124 mkSysLocal str uniq ty loc
1125 = Id uniq (mkLocalName uniq str True{-emph uniq-} loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
1127 mkUserLocal str uniq ty loc
1128 = Id uniq (mkLocalName uniq str False{-emph name-} loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
1130 -- mkUserId builds a local or top-level Id, depending on the name given
1131 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1132 mkUserId name ty pragma_info
1134 = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo
1136 = Id (nameUnique name) name ty
1137 (if isLocallyDefinedName name then TopLevId else ImportedId)
1138 pragma_info noIdInfo
1145 -- for a SpecPragmaId being created by the compiler out of thin air...
1146 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1147 mkSpecPragmaId str uniq ty specid loc
1148 = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty))
1151 mkSpecId u unspec ty_maybes ty info
1152 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1153 Id u n ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1155 -- Specialised version of constructor: only used in STG and code generation
1156 -- Note: The specialsied Id has the same unique as the unspeced Id
1158 mkSameSpecCon ty_maybes unspec@(Id u n ty info details)
1159 = ASSERT(isDataCon unspec)
1160 ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1161 Id u n new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1163 new_ty = specialiseTy ty ty_maybes 0
1165 localiseId :: Id -> Id
1166 localiseId id@(Id u n ty info details)
1167 = Id u (mkShortName name loc) ty info (LocalId (no_free_tvs ty))
1169 name = getOccName id
1173 mkIdWithNewUniq :: Id -> Unique -> Id
1175 mkIdWithNewUniq (Id _ n ty details prag info) u
1176 = Id u (changeUnique n u) ty details prag info
1179 Make some local @Ids@ for a template @CoreExpr@. These have bogus
1180 @Uniques@, but that's OK because the templates are supposed to be
1181 instantiated before use.
1183 mkTemplateLocals :: [Type] -> [Id]
1184 mkTemplateLocals tys
1185 = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1186 (getBuiltinUniques (length tys))
1191 getIdInfo :: GenId ty -> IdInfo
1192 getPragmaInfo :: GenId ty -> PragmaInfo
1194 getIdInfo (Id _ _ _ _ _ info) = info
1195 getPragmaInfo (Id _ _ _ _ info _) = info
1198 replaceIdInfo :: Id -> IdInfo -> Id
1200 replaceIdInfo (Id u n ty _ details) info = Id u n ty info details
1202 selectIdInfoForSpecId :: Id -> IdInfo
1203 selectIdInfoForSpecId unspec
1204 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1205 noIdInfo `addInfo_UF` getIdUnfolding unspec
1209 %************************************************************************
1211 \subsection[Id-arities]{Arity-related functions}
1213 %************************************************************************
1215 For locally-defined Ids, the code generator maintains its own notion
1216 of their arities; so it should not be asking... (but other things
1217 besides the code-generator need arity info!)
1220 getIdArity :: Id -> ArityInfo
1221 getIdArity (Id _ _ _ _ _ id_info) = getInfo id_info
1223 dataConArity :: DataCon -> Int
1224 dataConArity id@(Id _ _ _ _ _ id_info)
1225 = ASSERT(isDataCon id)
1226 case (arityMaybe (getInfo id_info)) of
1227 Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1230 addIdArity :: Id -> Int -> Id
1231 addIdArity (Id u n ty details pinfo info) arity
1232 = Id u n ty details pinfo (info `addInfo` (mkArityInfo arity))
1235 %************************************************************************
1237 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1239 %************************************************************************
1243 -> [StrictnessMark] -> [FieldLabel]
1244 -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1247 -- can get the tag and all the pieces of the type from the Type
1249 mkDataCon n stricts fields tvs ctxt args_tys tycon
1250 = ASSERT(length stricts == length args_tys)
1253 -- NB: data_con self-recursion; should be OK as tags are not
1254 -- looked at until late in the game.
1259 (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
1263 data_con_tag = position_within fIRST_TAG data_con_family
1265 data_con_family = tyConDataCons tycon
1267 position_within :: Int -> [Id] -> Int
1269 position_within acc (c:cs)
1270 = if c == data_con then acc else position_within (acc+1) cs
1272 position_within acc []
1273 = panic "mkDataCon: con not found in family"
1277 = mkSigmaTy tvs ctxt
1278 (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1280 datacon_info = noIdInfo `addInfo_UF` unfolding
1281 `addInfo` mkArityInfo arity
1282 --ToDo: `addInfo` specenv
1284 arity = length args_tys
1291 -- else -- do some business...
1293 (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1294 tyvar_tys = mkTyVarTys tyvars
1296 case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
1298 mkUnfolding EssentialUnfolding -- for data constructors
1299 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1302 mk_uf_bits tvs ctxt arg_tys tycon
1304 (inst_env, tyvars, tyvar_tys)
1305 = instantiateTyVarTemplates tvs
1308 -- the "context" and "arg_tys" have TyVarTemplates in them, so
1309 -- we instantiate those types to have the right TyVars in them
1311 case (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1312 of { inst_dict_tys ->
1313 case (map (instantiateTauTy inst_env) arg_tys) of { inst_arg_tys ->
1315 -- We can only have **ONE** call to mkTemplateLocals here;
1316 -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1317 -- (Mega-Sigh) [ToDo]
1318 case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars ->
1320 case (splitAt (length ctxt) all_vars) of { (dict_vars, vars) ->
1322 (tyvars, dict_vars, vars)
1325 -- these are really dubious Types, but they are only to make the
1326 -- binders for the lambdas for tossed-away dicts.
1327 ctxt_ty (clas, ty) = mkDictTy clas ty
1332 mkTupleCon :: Arity -> Id
1335 = Id unique n ty (TupleConId arity) NoPragmaInfo tuplecon_info
1337 n = mkTupleDataConName arity
1339 ty = mkSigmaTy tyvars []
1340 (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1341 tycon = mkTupleTyCon arity
1342 tyvars = take arity alphaTyVars
1343 tyvar_tys = mkTyVarTys tyvars
1346 = noIdInfo `addInfo_UF` unfolding
1347 `addInfo` mkArityInfo arity
1348 --LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1355 -- else -- do some business...
1357 (tyvars, dict_vars, vars) = mk_uf_bits arity
1358 tyvar_tys = mkTyVarTys tyvars
1360 case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
1362 EssentialUnfolding -- data constructors
1363 (mkLam tyvars (dict_vars ++ vars) plain_Con) }
1366 = case (mkTemplateLocals tyvar_tys) of { vars ->
1367 (tyvars, [], vars) }
1369 tyvar_tmpls = take arity alphaTyVars
1370 (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
1374 fIRST_TAG = 1 -- Tags allocated from here for real constructors
1378 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1379 dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _) _ _) = tag
1380 dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG
1381 dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
1383 dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
1384 dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
1385 dataConTyCon (Id _ _ _ (TupleConId a) _ _) = mkTupleTyCon a
1387 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1388 -- will panic if not a DataCon
1390 dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1391 = (tyvars, theta_ty, arg_tys, tycon)
1393 dataConSig (Id _ _ _ (TupleConId arity) _ _)
1394 = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1396 tyvars = take arity alphaTyVars
1397 tyvar_tys = mkTyVarTys tyvars
1399 dataConFieldLabels :: DataCon -> [FieldLabel]
1400 dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields
1401 dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = []
1403 dataConStrictMarks :: DataCon -> [StrictnessMark]
1404 dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts
1405 dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _)
1406 = nOfThem arity NotMarkedStrict
1408 dataConArgTys :: DataCon
1409 -> [Type] -- Instantiated at these types
1410 -> [Type] -- Needs arguments of these types
1411 dataConArgTys con_id inst_tys
1412 = map (instantiateTy tenv) arg_tys
1414 (tyvars, _, arg_tys, _) = dataConSig con_id
1415 tenv = zipEqual "dataConArgTys" tyvars inst_tys
1419 mkRecordSelId field_label selector_ty
1420 = Id (nameUnique name)
1423 (RecordSelId field_label)
1427 name = fieldLabelName field_label
1429 recordSelectorFieldLabel :: Id -> FieldLabel
1430 recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl
1434 Data type declarations are of the form:
1436 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1438 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1439 @C1 x y z@, we want a function binding:
1441 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1443 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1444 2nd-order polymorphic lambda calculus with explicit types.
1446 %************************************************************************
1448 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1450 %************************************************************************
1452 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1453 and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
1454 @TyVars@ don't really have to be new, because we are only producing a
1457 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1460 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1461 EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the
1462 example above: a, b, and x, y, z], which is enough (in the important
1463 \tr{DsExpr} case). (The middle set of @Ids@ is binders for any
1464 dictionaries, in the even of an overloaded data-constructor---none at
1468 getIdUnfolding :: Id -> UnfoldingDetails
1470 getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
1473 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1474 addIdUnfolding id@(Id u n ty info details) unfold_details
1476 case (isLocallyDefined id, unfold_details) of
1477 (_, NoUnfoldingDetails) -> True
1478 (True, IWantToBeINLINEd _) -> True
1479 (False, IWantToBeINLINEd _) -> False -- v bad
1483 Id u n ty (info `addInfo_UF` unfold_details) details
1487 In generating selector functions (take a dictionary, give back one
1488 component...), we need to what out for the nothing-to-select cases (in
1489 which case the ``selector'' is just an identity function):
1491 class Eq a => Foo a { } # the superdict selector for "Eq"
1493 class Foo a { op :: Complex b => c -> b -> a }
1494 # the method selector for "op";
1495 # note local polymorphism...
1498 %************************************************************************
1500 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1502 %************************************************************************
1505 getIdDemandInfo :: Id -> DemandInfo
1506 getIdDemandInfo (Id _ _ _ _ _ info) = getInfo info
1508 addIdDemandInfo :: Id -> DemandInfo -> Id
1509 addIdDemandInfo (Id u n ty details prags info) demand_info
1510 = Id u n ty details prags (info `addInfo` demand_info)
1514 getIdUpdateInfo :: Id -> UpdateInfo
1515 getIdUpdateInfo (Id _ _ _ _ _ info) = getInfo info
1517 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1518 addIdUpdateInfo (Id u n ty details prags info) upd_info
1519 = Id u n ty details prags (info `addInfo` upd_info)
1524 getIdArgUsageInfo :: Id -> ArgUsageInfo
1525 getIdArgUsageInfo (Id u n ty info details) = getInfo info
1527 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1528 addIdArgUsageInfo (Id u n ty info details) au_info
1529 = Id u n ty (info `addInfo` au_info) details
1535 getIdFBTypeInfo :: Id -> FBTypeInfo
1536 getIdFBTypeInfo (Id u n ty info details) = getInfo info
1538 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1539 addIdFBTypeInfo (Id u n ty info details) upd_info
1540 = Id u n ty (info `addInfo` upd_info) details
1546 getIdSpecialisation :: Id -> SpecEnv
1547 getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
1549 addIdSpecialisation :: Id -> SpecEnv -> Id
1550 addIdSpecialisation (Id u n ty details prags info) spec_info
1551 = Id u n ty details prags (info `addInfo` spec_info)
1555 Strictness: we snaffle the info out of the IdInfo.
1558 getIdStrictness :: Id -> StrictnessInfo
1560 getIdStrictness (Id _ _ _ _ _ info) = getInfo info
1562 addIdStrictness :: Id -> StrictnessInfo -> Id
1564 addIdStrictness (Id u n ty details prags info) strict_info
1565 = Id u n ty details prags (info `addInfo` strict_info)
1568 %************************************************************************
1570 \subsection[Id-comparison]{Comparison functions for @Id@s}
1572 %************************************************************************
1574 Comparison: equality and ordering---this stuff gets {\em hammered}.
1577 cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = cmp u1 u2
1578 -- short and very sweet
1582 instance Ord3 (GenId ty) where
1585 instance Eq (GenId ty) where
1586 a == b = case cmpId a b of { EQ_ -> True; _ -> False }
1587 a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
1589 instance Ord (GenId ty) where
1590 a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
1591 a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
1592 a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
1593 a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
1594 _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1597 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1598 account when comparing two data constructors. We need to do this
1599 because a specialised data constructor has the same Unique as its
1600 unspecialised counterpart.
1603 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1605 cmpId_withSpecDataCon id1 id2
1606 | eq_ids && isDataCon id1 && isDataCon id2
1607 = cmpEqDataCon id1 id2
1612 cmp_ids = cmpId id1 id2
1613 eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
1615 cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _)
1616 = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1618 cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_
1619 cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_
1620 cmpEqDataCon _ _ = EQ_
1623 %************************************************************************
1625 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1627 %************************************************************************
1630 instance Outputable ty => Outputable (GenId ty) where
1631 ppr sty id = pprId sty id
1633 -- and a SPECIALIZEd one:
1634 instance Outputable {-Id, i.e.:-}(GenId Type) where
1635 ppr sty id = pprId sty id
1637 showId :: PprStyle -> Id -> String
1638 showId sty id = ppShow 80 (pprId sty id)
1641 -- for DictFuns (instances) and const methods (instance code bits we
1642 -- can call directly): exported (a) if *either* the class or
1643 -- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
1644 -- class and tycon are from PreludeCore [non-std, but convenient]
1645 -- *and* the thing was defined in this module.
1647 instance_export_flag :: Class -> Type -> Bool -> ExportFlag
1649 instance_export_flag clas inst_ty from_here
1650 = panic "Id:instance_export_flag"
1652 = if instanceIsExported clas inst_ty from_here
1658 Default printing code (not used for interfaces):
1660 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1662 pprId sty (Id u n _ _ _ _) = ppr sty n
1663 -- WDP 96/05/06: We can re-elaborate this as we go along...
1667 idUnique (Id u _ _ _ _ _) = u
1669 instance Uniquable (GenId ty) where
1672 instance NamedThing (GenId ty) where
1673 getName this_id@(Id u n _ details _ _) = n
1678 get (SysLocalId _) = n
1679 get (SpecPragmaId _ _) = n
1683 get (InstId n _) = n
1684 get (DataConId _ _ _ _ _ _ _) = n
1685 get (TupleConId _) = n
1686 get (RecordSelId l) = getName l
1687 get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id)
1690 get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ???
1691 mod -> (mod, classOpString op)
1693 get (SpecId unspec ty_maybes _)
1694 = case moduleNamePair unspec of { (mod, unspec_nm) ->
1695 case specMaybeTysSuffix ty_maybes of { tys_suffix ->
1698 (if not (toplevelishId unspec)
1703 get (WorkerId unwrkr)
1704 = case moduleNamePair unwrkr of { (mod, unwrkr_nm) ->
1707 (if not (toplevelishId unwrkr)
1713 -- the remaining internally-generated flavours of
1714 -- Ids really do not have meaningful "original name" stuff,
1715 -- but we need to make up something (usually for debugging output)
1717 = case (getIdNamePieces True this_id) of { (piece1:pieces) ->
1718 case [ _CONS_ '.' p | p <- pieces ] of { dotted_pieces ->
1719 (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) }}
1723 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1724 the @Uniques@ out of local @Ids@ given to it.
1726 %************************************************************************
1728 \subsection{@IdEnv@s and @IdSet@s}
1730 %************************************************************************
1733 type IdEnv elt = UniqFM elt
1735 nullIdEnv :: IdEnv a
1737 mkIdEnv :: [(GenId ty, a)] -> IdEnv a
1738 unitIdEnv :: GenId ty -> a -> IdEnv a
1739 addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
1740 growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
1741 growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1743 delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
1744 delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
1745 combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1746 mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
1747 modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
1748 rngIdEnv :: IdEnv a -> [a]
1750 isNullIdEnv :: IdEnv a -> Bool
1751 lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
1752 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1756 addOneToIdEnv = addToUFM
1757 combineIdEnvs = plusUFM_C
1758 delManyFromIdEnv = delListFromUFM
1759 delOneFromIdEnv = delFromUFM
1761 lookupIdEnv = lookupUFM
1764 nullIdEnv = emptyUFM
1768 growIdEnvList env pairs = plusUFM env (listToUFM pairs)
1769 isNullIdEnv env = sizeUFM env == 0
1770 lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
1772 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1773 -- modify function, and put it back.
1775 modifyIdEnv env mangle_fn key
1776 = case (lookupIdEnv env key) of
1778 Just xx -> addOneToIdEnv env key (mangle_fn xx)
1782 type GenIdSet ty = UniqSet (GenId ty)
1783 type IdSet = UniqSet (GenId Type)
1785 emptyIdSet :: GenIdSet ty
1786 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1787 unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1788 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1789 idSetToList :: GenIdSet ty -> [GenId ty]
1790 unitIdSet :: GenId ty -> GenIdSet ty
1791 addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
1792 elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
1793 minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1794 isEmptyIdSet :: GenIdSet ty -> Bool
1795 mkIdSet :: [GenId ty] -> GenIdSet ty
1797 emptyIdSet = emptyUniqSet
1798 unitIdSet = unitUniqSet
1799 addOneToIdSet = addOneToUniqSet
1800 intersectIdSets = intersectUniqSets
1801 unionIdSets = unionUniqSets
1802 unionManyIdSets = unionManyUniqSets
1803 idSetToList = uniqSetToList
1804 elementOfIdSet = elementOfUniqSet
1805 minusIdSet = minusUniqSet
1806 isEmptyIdSet = isEmptyUniqSet
1811 addId, nmbrId :: Id -> NmbrM Id
1813 addId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1814 = case (lookupUFM_Directly idenv u) of
1815 Just xx -> _trace "addId: already in map!" $
1818 if toplevelishId id then
1819 _trace "addId: can't add toplevelish!" $
1821 else -- alloc a new unique for this guy
1822 -- and add an entry in the idenv
1823 -- NB: *** KNOT-TYING ***
1825 nenv_plus_id = NmbrEnv (incrUnique ui) ut uu
1826 (addToUFM_Directly idenv u new_id)
1829 (nenv2, new_ty) = nmbrType ty nenv_plus_id
1830 (nenv3, new_det) = nmbr_details det nenv2
1832 new_id = Id ui n new_ty new_det prag info
1836 nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1837 = case (lookupUFM_Directly idenv u) of
1838 Just xx -> (nenv, xx)
1840 if not (toplevelishId id) then
1841 _trace "nmbrId: lookup failed" $
1845 (nenv2, new_ty) = nmbrType ty nenv
1846 (nenv3, new_det) = nmbr_details det nenv2
1848 new_id = Id u n new_ty new_det prag info
1853 nmbr_details :: IdDetails -> NmbrM IdDetails
1855 nmbr_details (DataConId tag marks fields tvs theta arg_tys tc)
1856 = mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs ->
1857 mapNmbr nmbrField fields `thenNmbr` \ new_fields ->
1858 mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
1859 mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys ->
1860 returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_arg_tys tc)
1863 = --nmbrClass c `thenNmbr` \ new_c ->
1864 nmbrType t `thenNmbr` \ new_t ->
1865 returnNmbr (c, new_t)
1867 -- ToDo:add more cases as needed
1868 nmbr_details other_details = returnNmbr other_details
1871 nmbrField (FieldLabel n ty tag)
1872 = nmbrType ty `thenNmbr` \ new_ty ->
1873 returnNmbr (FieldLabel n new_ty tag)