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, dataConRawArgTys, dataConArgTys,
40 dataConTyCon, dataConArity,
43 recordSelectorFieldLabel,
46 isDataCon, isTupleCon,
48 isSpecId_maybe, isSpecPragmaId_maybe,
49 toplevelishId, externallyVisibleId,
50 isTopLevId, isWorkerId, isWrapperId,
51 isImportedId, isSysLocalId,
53 isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
56 isConstMethodId_maybe,
57 cmpId_withSpecDataCon,
60 unfoldingUnfriendlyId, -- ToDo: rm, eventually
62 -- dataConMentionsNonPreludeTyCon,
65 applySubstToId, applyTypeEnvToId,
66 -- not exported: apply_to_Id, -- please don't use this, generally
68 -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
69 getIdArity, addIdArity,
70 getIdDemandInfo, addIdDemandInfo,
71 getIdSpecialisation, addIdSpecialisation,
72 getIdStrictness, addIdStrictness,
73 getIdUnfolding, addIdUnfolding,
74 getIdUpdateInfo, addIdUpdateInfo,
75 getIdArgUsageInfo, addIdArgUsageInfo,
76 getIdFBTypeInfo, addIdFBTypeInfo,
77 -- don't export the types, lest OptIdInfo be dragged in!
87 -- "Environments" keyed off of Ids, and sets of Ids
89 lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
90 growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
91 delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
94 -- and to make the interface self-sufficient...
95 GenIdSet(..), IdSet(..)
99 IMPORT_DELOOPER(IdLoop) -- for paranoia checking
100 IMPORT_DELOOPER(TyLoop) -- for paranoia checking
103 import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
104 import CStrings ( identToC, cSEP )
106 import Maybes ( maybeToBool )
107 import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
108 isLocallyDefinedName, isPreludeDefinedName,
109 mkTupleDataConName, mkCompoundName, mkCompoundName2,
110 isLexSym, isLexSpecialSym, getLocalName,
111 isLocallyDefined, isPreludeDefined, changeUnique,
112 getOccName, moduleNamePair, origName, nameOf,
113 isExported, ExportFlag(..),
116 import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
117 import PragmaInfo ( PragmaInfo(..) )
118 import PprEnv -- ( NmbrM(..), NmbrEnv(..) )
119 import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
125 import SrcLoc ( mkBuiltinSrcLoc )
126 import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
127 import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
128 applyTyCon, isPrimType, instantiateTy,
129 tyVarsOfType, applyTypeEnvToTy, typePrimRep,
130 GenType, ThetaType(..), TauType(..), Type(..)
132 import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
134 import UniqSet -- practically all of it
135 import Unique ( getBuiltinUniques, pprUnique, showUnique,
137 Unique{-instance Ord3-}
139 import Util ( mapAccumL, nOfThem, zipEqual,
140 panic, panic#, pprPanic, assertPanic
144 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
147 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
148 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
149 strictness). The essential info about different kinds of @Ids@ is
152 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
156 Unique -- Key for fast comparison
158 ty -- Id's type; used all the time;
159 IdDetails -- Stuff about individual kinds of Ids.
160 PragmaInfo -- Properties of this Id requested by programmer
161 -- eg specialise-me, inline-me
162 IdInfo -- Properties of this Id deduced by compiler
166 data StrictnessMark = MarkedStrict | NotMarkedStrict
170 ---------------- Local values
172 = LocalId Bool -- Local name; mentioned by the user
173 -- True <=> no free type vars
175 | SysLocalId Bool -- Local name; made up by the compiler
178 | SpecPragmaId -- Local name; introduced by the compiler
179 (Maybe Id) -- for explicit specid in pragma
180 Bool -- as for LocalId
182 ---------------- Global values
184 | ImportedId -- Global name (Imported or Implicit); Id imported from an interface
186 | PreludeId -- Global name (Builtin); Builtin prelude Ids
188 | TopLevId -- Global name (LocalDef); Top-level in the orig source pgm
189 -- (not moved there by transformations).
191 -- a TopLevId's type may contain free type variables, if
192 -- the monomorphism restriction applies.
194 ---------------- Data constructors
197 [StrictnessMark] -- Strict args; length = arity
198 [FieldLabel] -- Field labels for this constructor
200 [TyVar] [(Class,Type)] [Type] TyCon
202 -- forall tyvars . theta_ty =>
203 -- unitype_1 -> ... -> unitype_n -> tycon tyvars
205 | TupleConId Int -- Its arity
207 | RecordSelId FieldLabel
209 ---------------- Things to do with overloading
211 | SuperDictSelId -- Selector for superclass dictionary
212 Class -- The class (input dict)
213 Class -- The superclass (result dict)
215 | MethodSelId Class -- An overloaded class operation, with
216 -- a fully polymorphic type. Its code
217 -- just selects a method from the
218 -- dictionary. The class.
219 ClassOp -- The operation
221 -- NB: The IdInfo for a MethodSelId has all the info about its
222 -- related "constant method Ids", which are just
223 -- specialisations of this general one.
225 | DefaultMethodId -- Default method for a particular class op
226 Class -- same class, <blah-blah> info as MethodSelId
227 ClassOp -- (surprise, surprise)
228 Bool -- True <=> I *know* this default method Id
229 -- is a generated one that just says
230 -- `error "No default method for <op>"'.
233 | DictFunId Class -- A DictFun is uniquely identified
234 Type -- by its class and type; this type has free type vars,
235 -- whose identity is irrelevant. Eg Class = Eq
237 -- The "a" is irrelevant. As it is too painful to
238 -- actually do comparisons that way, we kindly supply
239 -- a Unique for that purpose.
240 (Maybe Module) -- module where instance came from; Nothing => Prelude
243 | ConstMethodId -- A method which depends only on the type of the
244 -- instance, and not on any further dictionaries etc.
245 Class -- Uniquely identified by:
246 Type -- (class, type, classop) triple
248 (Maybe Module) -- module where instance came from; Nothing => Prelude
250 | InstId -- An instance of a dictionary, class operation,
251 -- or overloaded value (Local name)
252 Bool -- as for LocalId
254 | SpecId -- A specialisation of another Id
255 Id -- Id of which this is a specialisation
256 [Maybe Type] -- Types at which it is specialised;
257 -- A "Nothing" says this type ain't relevant.
258 Bool -- True <=> no free type vars; it's not enough
259 -- to know about the unspec version, because
260 -- we may specialise to a type w/ free tyvars
261 -- (i.e., in one of the "Maybe Type" dudes).
263 | WorkerId -- A "worker" for some other Id
264 Id -- Id for which this is a worker
272 DictFunIds are generated from instance decls.
277 instance Foo a => Foo [a] where
280 generates the dict fun id decl
282 dfun.Foo.[*] = \d -> ...
284 The dfun id is uniquely named by the (class, type) pair. Notice, it
285 isn't a (class,tycon) pair any more, because we may get manually or
286 automatically generated specialisations of the instance decl:
288 instance Foo [Int] where
295 The type variables in the name are irrelevant; we print them as stars.
298 Constant method ids are generated from instance decls where
299 there is no context; that is, no dictionaries are needed to
300 construct the method. Example
302 instance Foo Int where
305 Then we get a constant method
310 It is possible, albeit unusual, to have a constant method
311 for an instance decl which has type vars:
313 instance Foo [a] where
317 We get the constant method
321 So a constant method is identified by a class/op/type triple.
322 The type variables in the type are irrelevant.
325 For Ids whose names must be known/deducible in other modules, we have
326 to conjure up their worker's names (and their worker's worker's
327 names... etc) in a known systematic way.
330 %************************************************************************
332 \subsection[Id-documentation]{Documentation}
334 %************************************************************************
338 The @Id@ datatype describes {\em values}. The basic things we want to
339 know: (1)~a value's {\em type} (@idType@ is a very common
340 operation in the compiler); and (2)~what ``flavour'' of value it might
341 be---for example, it can be terribly useful to know that a value is a
345 %----------------------------------------------------------------------
346 \item[@DataConId@:] For the data constructors declared by a @data@
347 declaration. Their type is kept in {\em two} forms---as a regular
348 @Type@ (in the usual place), and also in its constituent pieces (in
349 the ``details''). We are frequently interested in those pieces.
351 %----------------------------------------------------------------------
352 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
353 the infinite family of tuples.
355 %----------------------------------------------------------------------
356 \item[@ImportedId@:] These are values defined outside this module.
357 {\em Everything} we want to know about them must be stored here (or in
360 %----------------------------------------------------------------------
361 \item[@PreludeId@:] ToDo
363 %----------------------------------------------------------------------
364 \item[@TopLevId@:] These are values defined at the top-level in this
365 module; i.e., those which {\em might} be exported (hence, a
366 @Name@). It does {\em not} include those which are moved to the
367 top-level through program transformations.
369 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
370 Theoretically, they could be floated inwards, but there's no known
371 advantage in doing so. This way, we can keep them with the same
372 @Unique@ throughout (no cloning), and, in general, we don't have to be
373 so paranoid about them.
375 In particular, we had the following problem generating an interface:
376 We have to ``stitch together'' info (1)~from the typechecker-produced
377 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
378 what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change}
379 between (1) and (2), you're sunk!
381 %----------------------------------------------------------------------
382 \item[@MethodSelId@:] A selector from a dictionary; it may select either
383 a method or a dictionary for one of the class's superclasses.
385 %----------------------------------------------------------------------
388 @mkDictFunId [a,b..] theta C T@ is the function derived from the
391 instance theta => C (T a b ..) where
394 It builds function @Id@ which maps dictionaries for theta,
395 to a dictionary for C (T a b ..).
397 *Note* that with the ``Mark Jones optimisation'', the theta may
398 include dictionaries for the immediate superclasses of C at the type
401 %----------------------------------------------------------------------
404 %----------------------------------------------------------------------
407 %----------------------------------------------------------------------
410 %----------------------------------------------------------------------
411 \item[@LocalId@:] A purely-local value, e.g., a function argument,
412 something defined in a @where@ clauses, ... --- but which appears in
413 the original program text.
415 %----------------------------------------------------------------------
416 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
417 the original program text; these are introduced by the compiler in
420 %----------------------------------------------------------------------
421 \item[@SpecPragmaId@:] Introduced by the compiler to record
422 Specialisation pragmas. It is dead code which MUST NOT be removed
423 before specialisation.
428 %----------------------------------------------------------------------
431 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
432 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
436 They have no free type variables, so if you are making a
437 type-variable substitution you don't need to look inside them.
439 They are constants, so they are not free variables. (When the STG
440 machine makes a closure, it puts all the free variables in the
441 closure; the above are not required.)
443 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
444 properties, but they may not.
447 %************************************************************************
449 \subsection[Id-general-funs]{General @Id@-related functions}
451 %************************************************************************
454 unsafeGenId2Id :: GenId ty -> Id
455 unsafeGenId2Id (Id u n ty d p i) = Id u n (panic "unsafeGenId2Id:ty") d p i
457 isDataCon id = is_data (unsafeGenId2Id id)
459 is_data (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
460 is_data (Id _ _ _ (TupleConId _) _ _) = True
461 is_data (Id _ _ _ (SpecId unspec _ _) _ _) = is_data unspec
462 is_data other = False
465 isTupleCon id = is_tuple (unsafeGenId2Id id)
467 is_tuple (Id _ _ _ (TupleConId _) _ _) = True
468 is_tuple (Id _ _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
469 is_tuple other = False
472 isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _)
473 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
474 Just (unspec, ty_maybes)
475 isSpecId_maybe other_id
478 isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId specid _) _ _)
480 isSpecPragmaId_maybe other_id
485 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a nested
486 @let(rec)@ (returns @False@), or whether it is {\em sure} to be
487 defined at top level (returns @True@). This is used to decide whether
488 the @Id@ is a candidate free variable. NB: you are only {\em sure}
489 about something if it returns @True@!
492 toplevelishId :: Id -> Bool
493 idHasNoFreeTyVars :: Id -> Bool
495 toplevelishId (Id _ _ _ details _ _)
498 chk (DataConId _ _ _ _ _ _ _) = True
499 chk (TupleConId _) = True
500 chk (RecordSelId _) = True
501 chk ImportedId = True
503 chk TopLevId = True -- NB: see notes
504 chk (SuperDictSelId _ _) = True
505 chk (MethodSelId _ _) = True
506 chk (DefaultMethodId _ _ _) = True
507 chk (DictFunId _ _ _) = True
508 chk (ConstMethodId _ _ _ _) = True
509 chk (SpecId unspec _ _) = toplevelishId unspec
510 -- depends what the unspecialised thing is
511 chk (WorkerId unwrkr) = toplevelishId unwrkr
512 chk (InstId _) = False -- these are local
513 chk (LocalId _) = False
514 chk (SysLocalId _) = False
515 chk (SpecPragmaId _ _) = False
517 idHasNoFreeTyVars (Id _ _ _ details _ info)
520 chk (DataConId _ _ _ _ _ _ _) = True
521 chk (TupleConId _) = True
522 chk (RecordSelId _) = True
523 chk ImportedId = True
526 chk (SuperDictSelId _ _) = True
527 chk (MethodSelId _ _) = True
528 chk (DefaultMethodId _ _ _) = True
529 chk (DictFunId _ _ _) = True
530 chk (ConstMethodId _ _ _ _) = True
531 chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
532 chk (SpecId _ _ no_free_tvs) = no_free_tvs
533 chk (InstId no_free_tvs) = no_free_tvs
534 chk (LocalId no_free_tvs) = no_free_tvs
535 chk (SysLocalId no_free_tvs) = no_free_tvs
536 chk (SpecPragmaId _ no_free_tvs) = no_free_tvs
540 isTopLevId (Id _ _ _ TopLevId _ _) = True
541 isTopLevId other = False
543 isImportedId (Id _ _ _ ImportedId _ _) = True
544 isImportedId other = False
546 isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
548 isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True
549 isSysLocalId other = False
551 isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True
552 isSpecPragmaId other = False
554 isMethodSelId (Id _ _ _ (MethodSelId _ _) _ _) = True
555 isMethodSelId _ = False
557 isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
558 isDefaultMethodId other = False
560 isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _)
561 = Just (cls, clsop, err)
562 isDefaultMethodId_maybe other = Nothing
564 isDictFunId (Id _ _ _ (DictFunId _ _ _) _ _) = True
565 isDictFunId other = False
567 isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True
568 isConstMethodId other = False
570 isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _) _ _)
571 = Just (cls, ty, clsop)
572 isConstMethodId_maybe other = Nothing
574 isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
575 isSuperDictSelId_maybe other_id = Nothing
577 isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
578 isWorkerId other = False
581 isWrapperId id = workerExists (getIdStrictness id)
587 pprIdInUnfolding :: IdSet -> Id -> Pretty
589 pprIdInUnfolding in_scopes v
594 if v `elementOfUniqSet` in_scopes then
595 pprUnique (idUnique v)
597 -- ubiquitous Ids with special syntax:
598 else if v == nilDataCon then
600 else if isTupleCon v then
601 ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
603 -- ones to think about:
606 (Id _ _ _ v_details _ _) = v
609 -- these ones must have been exported by their original module
610 ImportedId -> pp_full_name
611 PreludeId -> pp_full_name
613 -- these ones' exportedness checked later...
614 TopLevId -> pp_full_name
615 DataConId _ _ _ _ _ _ _ -> pp_full_name
617 RecordSelId lbl -> ppr sty lbl
619 -- class-ish things: class already recorded as "mentioned"
621 -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
623 -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
624 DefaultMethodId c o _
625 -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
627 -- instance-ish things: should we try to figure out
628 -- *exactly* which extra instances have to be exported? (ToDo)
630 -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
631 ConstMethodId c t o _
632 -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
634 -- specialisations and workers
635 SpecId unspec ty_maybes _
637 pp = pprIdInUnfolding in_scopes unspec
639 ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
640 ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
645 pp = pprIdInUnfolding in_scopes unwrkr
647 ppBeside (ppPStr SLIT("_WRKR_ ")) pp
649 -- anything else? we're nae interested
650 other_id -> panic "pprIdInUnfolding:mystery Id"
652 ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
656 (m_str, n_str) = moduleNamePair v
659 if isLexSym n_str && not (isLexSpecialSym n_str) then
660 ppBesides [ppLparen, ppPStr n_str, ppRparen]
664 if isPreludeDefined v then
667 ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
669 pp_class :: Class -> Pretty
670 pp_class_op :: ClassOp -> Pretty
671 pp_type :: Type -> Pretty
672 pp_ty_maybe :: Maybe Type -> Pretty
674 pp_class clas = ppr ppr_Unfolding clas
675 pp_class_op op = ppr ppr_Unfolding op
677 pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
679 pp_ty_maybe Nothing = ppPStr SLIT("_N_")
680 pp_ty_maybe (Just t) = pp_type t
684 @whatsMentionedInId@ ferrets out the types/classes/instances on which
685 this @Id@ depends. If this Id is to appear in an interface, then
686 those entities had Jolly Well be in scope. Someone else up the
687 call-tree decides that.
692 :: IdSet -- Ids known to be in scope
693 -> Id -- Id being processed
694 -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
696 whatsMentionedInId in_scopes v
701 = getMentionedTyConsAndClassesFromType v_ty
703 result0 id_bag = (id_bag, tycons, clss)
706 = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
707 tcs `unionBags` tycons,
711 if v `elementOfUniqSet` in_scopes then
712 result0 emptyBag -- v not added to "mentioned"
714 -- ones to think about:
717 (Id _ _ _ v_details _ _) = v
720 -- specialisations and workers
721 SpecId unspec ty_maybes _
723 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
725 result1 ids2 tcs2 cs2
729 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
731 result1 ids2 tcs2 cs2
733 anything_else -> result0 (unitBag v) -- v is added to "mentioned"
737 Tell them who my wrapper function is.
740 myWrapperMaybe :: Id -> Maybe Id
742 myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
743 myWrapperMaybe other_id = Nothing
748 unfoldingUnfriendlyId -- return True iff it is definitely a bad
749 :: Id -- idea to export an unfolding that
750 -> Bool -- mentions this Id. Reason: it cannot
751 -- possibly be seen in another module.
753 unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
756 unfoldingUnfriendlyId id
757 | not (externallyVisibleId id) -- that settles that...
760 unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper) _ _)
761 = class_thing wrapper
763 -- "class thing": If we're going to use this worker Id in
764 -- an interface, we *have* to be able to untangle the wrapper's
765 -- strictness when reading it back in. At the moment, this
766 -- is not always possible: in precisely those cases where
767 -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
769 class_thing (Id _ _ _ (SuperDictSelId _ _) _ _) = True
770 class_thing (Id _ _ _ (MethodSelId _ _) _ _) = True
771 class_thing (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
772 class_thing other = False
774 unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _) _ _)
775 -- a SPEC of a DictFunId can end up w/ gratuitous
776 -- TyVar(Templates) in the i/face; only a problem
777 -- if -fshow-pragma-name-errs; but we can do without the pain.
778 -- A HACK in any case (WDP 94/05/02)
779 = naughty_DictFunId dfun
781 unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _) _ _)
782 = naughty_DictFunId dfun -- similar deal...
784 unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
786 naughty_DictFunId :: IdDetails -> Bool
787 -- True <=> has a TyVar(Template) in the "type" part of its "name"
789 naughty_DictFunId (DictFunId _ _ _) = panic "False" -- came from outside; must be OK
790 naughty_DictFunId (DictFunId _ ty _)
791 = not (isGroundTy ty)
795 @externallyVisibleId@: is it true that another module might be
796 able to ``see'' this Id?
798 We need the @toplevelishId@ check as well as @isExported@ for when we
799 compile instance declarations in the prelude. @DictFunIds@ are
800 ``exported'' if either their class or tycon is exported, but, in
801 compiling the prelude, the compiler may not recognise that as true.
804 externallyVisibleId :: Id -> Bool
806 externallyVisibleId id@(Id _ _ _ details _ _)
807 = if isLocallyDefined id then
808 toplevelishId id && isExported id && not (weird_datacon details)
810 not (weird_tuplecon details)
811 -- if visible here, it must be visible elsewhere, too.
813 -- If it's a DataCon, it's not enough to know it (meaning
814 -- its TyCon) is exported; we need to know that it might
815 -- be visible outside. Consider:
817 -- data Foo a = Mumble | BigFoo a WeirdLocalType
819 -- We can't tell the outside world *anything* about Foo, because
820 -- of WeirdLocalType; but we need to know this when asked if
821 -- "Mumble" is externally visible...
824 weird_datacon (DataConId _ _ _ _ _ _ tycon)
825 = maybeToBool (maybePurelyLocalTyCon tycon)
827 weird_datacon not_a_datacon_therefore_not_weird = False
829 weird_tuplecon (TupleConId arity)
830 = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
831 weird_tuplecon _ = False
835 idWantsToBeINLINEd :: Id -> Bool
837 idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
838 idWantsToBeINLINEd _ = False
841 For @unlocaliseId@: See the brief commentary in
842 \tr{simplStg/SimplStg.lhs}.
846 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
848 unlocaliseId mod (Id u fn ty info TopLevId)
849 = Just (Id u (unlocaliseFullName fn) ty info TopLevId)
851 unlocaliseId mod (Id u sn ty info (LocalId no_ftvs))
852 = --false?: ASSERT(no_ftvs)
854 full_name = unlocaliseShortName mod u sn
856 Just (Id u full_name ty info TopLevId)
858 unlocaliseId mod (Id u sn ty info (SysLocalId no_ftvs))
859 = --false?: on PreludeGlaST: ASSERT(no_ftvs)
861 full_name = unlocaliseShortName mod u sn
863 Just (Id u full_name ty info TopLevId)
865 unlocaliseId mod (Id u n ty info (SpecId unspec ty_maybes no_ftvs))
866 = case unlocalise_parent mod u unspec of
868 Just xx -> Just (Id u n ty info (SpecId xx ty_maybes no_ftvs))
870 unlocaliseId mod (Id u n ty info (WorkerId unwrkr))
871 = case unlocalise_parent mod u unwrkr of
873 Just xx -> Just (Id u n ty info (WorkerId xx))
875 unlocaliseId mod (Id u name ty info (InstId no_ftvs))
876 = Just (Id u full_name ty info TopLevId)
877 -- type might be wrong, but it hardly matters
878 -- at this stage (just before printing C) ToDo
880 name = getLocalName name
881 full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
883 unlocaliseId mod other_id = Nothing
886 -- we have to be Very Careful for workers/specs of
889 unlocalise_parent mod uniq (Id _ sn ty info (LocalId no_ftvs))
890 = --false?: ASSERT(no_ftvs)
892 full_name = unlocaliseShortName mod uniq sn
894 Just (Id uniq full_name ty info TopLevId)
896 unlocalise_parent mod uniq (Id _ sn ty info (SysLocalId no_ftvs))
897 = --false?: ASSERT(no_ftvs)
899 full_name = unlocaliseShortName mod uniq sn
901 Just (Id uniq full_name ty info TopLevId)
903 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
904 -- we're OK otherwise
908 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
909 `Top-levelish Ids'' cannot have any free type variables, so applying
910 the type-env cannot have any effect. (NB: checked in CoreLint?)
912 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
913 former ``should be'' the usual crunch point.
916 type TypeEnv = TyVarEnv Type
918 applyTypeEnvToId :: TypeEnv -> Id -> Id
920 applyTypeEnvToId type_env id@(Id _ _ ty _ _ _)
921 | idHasNoFreeTyVars id
924 = apply_to_Id ( \ ty ->
925 applyTypeEnvToTy type_env ty
930 apply_to_Id :: (Type -> Type) -> Id -> Id
932 apply_to_Id ty_fn (Id u n ty details prag info)
936 Id u n new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
938 apply_to_details (SpecId unspec ty_maybes no_ftvs)
940 new_unspec = apply_to_Id ty_fn unspec
941 new_maybes = map apply_to_maybe ty_maybes
943 SpecId new_unspec new_maybes (no_free_tvs ty)
944 -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
946 apply_to_maybe Nothing = Nothing
947 apply_to_maybe (Just ty) = Just (ty_fn ty)
949 apply_to_details (WorkerId unwrkr)
951 new_unwrkr = apply_to_Id ty_fn unwrkr
955 apply_to_details other = other
958 Sadly, I don't think the one using the magic typechecker substitution
959 can be done with @apply_to_Id@. Here we go....
961 Strictness is very important here. We can't leave behind thunks
962 with pointers to the substitution: it {\em must} be single-threaded.
966 applySubstToId :: Subst -> Id -> (Subst, Id)
968 applySubstToId subst id@(Id u n ty info details)
969 -- *cannot* have a "idHasNoFreeTyVars" get-out clause
970 -- because, in the typechecker, we are still
971 -- *concocting* the types.
972 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
973 case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
974 case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
975 (s4, Id u n new_ty new_info new_details) }}}
977 apply_to_details subst _ (InstId inst no_ftvs)
978 = case (applySubstToInst subst inst) of { (s2, new_inst) ->
979 (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
981 apply_to_details subst new_ty (SpecId unspec ty_maybes _)
982 = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
983 case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
984 (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
985 -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
987 apply_to_maybe subst Nothing = (subst, Nothing)
988 apply_to_maybe subst (Just ty)
989 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
992 apply_to_details subst _ (WorkerId unwrkr)
993 = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
994 (s2, WorkerId new_unwrkr) }
996 apply_to_details subst _ other = (subst, other)
1000 %************************************************************************
1002 \subsection[Id-type-funs]{Type-related @Id@ functions}
1004 %************************************************************************
1007 idType :: GenId ty -> ty
1009 idType (Id _ _ ty _ _ _) = ty
1014 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1016 getMentionedTyConsAndClassesFromId id
1017 = getMentionedTyConsAndClassesFromType (idType id)
1022 idPrimRep i = typePrimRep (idType i)
1027 getInstIdModule (Id _ _ _ (DictFunId _ _ mod)) = mod
1028 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ mod)) = mod
1029 getInstIdModule other = panic "Id:getInstIdModule"
1033 %************************************************************************
1035 \subsection[Id-overloading]{Functions related to overloading}
1037 %************************************************************************
1040 mkSuperDictSelId u c sc ty info
1041 = Id u n ty (SuperDictSelId c sc) NoPragmaInfo info
1043 cname = getName c -- we get other info out of here
1045 n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname
1047 mkMethodSelId u rec_c op ty info
1048 = Id u n ty (MethodSelId rec_c op) NoPragmaInfo info
1050 cname = getName rec_c -- we get other info out of here
1052 n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname
1054 mkDefaultMethodId u rec_c op gen ty info
1055 = Id u n ty (DefaultMethodId rec_c op gen) NoPragmaInfo info
1057 cname = getName rec_c -- we get other info out of here
1059 n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname
1061 mkDictFunId u c ity full_ty from_here locn mod info
1062 = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info
1064 n = mkCompoundName2 u SLIT("dfun") [origName c] (getTypeString ity) from_here locn
1066 mkConstMethodId u c op ity full_ty from_here locn mod info
1067 = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info
1069 n = mkCompoundName2 u SLIT("const") [origName c, Unqual (classOpString op)] (getTypeString ity) from_here locn
1071 mkWorkerId u unwrkr ty info
1072 = Id u n ty (WorkerId unwrkr) NoPragmaInfo info
1074 unwrkr_name = getName unwrkr
1076 n = mkCompoundName u SLIT("wrk") [origName unwrkr_name] unwrkr_name
1078 mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
1081 getConstMethodId clas op ty
1082 = -- constant-method info is hidden in the IdInfo of
1083 -- the class-op id (as mentioned up above).
1085 sel_id = getMethodSelId clas op
1087 case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1089 Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
1090 ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1091 ppr PprDebug sel_id],
1092 ppStr "(This can arise if an interface pragma refers to an instance",
1093 ppStr "but there is no imported interface which *defines* that instance.",
1094 ppStr "The info above, however ugly, should indicate what else you need to import."
1099 %************************************************************************
1101 \subsection[local-funs]{@LocalId@-related functions}
1103 %************************************************************************
1106 mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
1107 mkPreludeId n ty info = Id (nameUnique n) n ty PreludeId NoPragmaInfo info
1110 updateIdType :: Id -> Type -> Id
1111 updateIdType (Id u n _ info details) ty = Id u n ty info details
1116 type MyTy a b = GenType (GenTyVar a) b
1117 type MyId a b = GenId (MyTy a b)
1119 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1121 -- SysLocal: for an Id being created by the compiler out of thin air...
1122 -- UserLocal: an Id with a name the user might recognize...
1123 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1125 mkSysLocal str uniq ty loc
1126 = Id uniq (mkLocalName uniq str True{-emph uniq-} loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
1128 mkUserLocal str uniq ty loc
1129 = Id uniq (mkLocalName uniq str False{-emph name-} loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
1131 -- mkUserId builds a local or top-level Id, depending on the name given
1132 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1133 mkUserId name ty pragma_info
1135 = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo
1137 = Id (nameUnique name) name ty
1138 (if isLocallyDefinedName name then TopLevId else ImportedId)
1139 pragma_info noIdInfo
1146 -- for a SpecPragmaId being created by the compiler out of thin air...
1147 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1148 mkSpecPragmaId str uniq ty specid loc
1149 = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty))
1152 mkSpecId u unspec ty_maybes ty info
1153 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1154 Id u n ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1156 -- Specialised version of constructor: only used in STG and code generation
1157 -- Note: The specialsied Id has the same unique as the unspeced Id
1159 mkSameSpecCon ty_maybes unspec@(Id u n ty info details)
1160 = ASSERT(isDataCon unspec)
1161 ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1162 Id u n new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1164 new_ty = specialiseTy ty ty_maybes 0
1166 localiseId :: Id -> Id
1167 localiseId id@(Id u n ty info details)
1168 = Id u (mkShortName name loc) ty info (LocalId (no_free_tvs ty))
1170 name = getOccName id
1174 mkIdWithNewUniq :: Id -> Unique -> Id
1176 mkIdWithNewUniq (Id _ n ty details prag info) u
1177 = Id u (changeUnique n u) ty details prag info
1180 Make some local @Ids@ for a template @CoreExpr@. These have bogus
1181 @Uniques@, but that's OK because the templates are supposed to be
1182 instantiated before use.
1184 mkTemplateLocals :: [Type] -> [Id]
1185 mkTemplateLocals tys
1186 = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1187 (getBuiltinUniques (length tys))
1192 getIdInfo :: GenId ty -> IdInfo
1193 getPragmaInfo :: GenId ty -> PragmaInfo
1195 getIdInfo (Id _ _ _ _ _ info) = info
1196 getPragmaInfo (Id _ _ _ _ info _) = info
1199 replaceIdInfo :: Id -> IdInfo -> Id
1201 replaceIdInfo (Id u n ty _ details) info = Id u n ty info details
1203 selectIdInfoForSpecId :: Id -> IdInfo
1204 selectIdInfoForSpecId unspec
1205 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1206 noIdInfo `addInfo_UF` getIdUnfolding unspec
1210 %************************************************************************
1212 \subsection[Id-arities]{Arity-related functions}
1214 %************************************************************************
1216 For locally-defined Ids, the code generator maintains its own notion
1217 of their arities; so it should not be asking... (but other things
1218 besides the code-generator need arity info!)
1221 getIdArity :: Id -> ArityInfo
1222 getIdArity (Id _ _ _ _ _ id_info) = getInfo id_info
1224 dataConArity :: DataCon -> Int
1225 dataConArity id@(Id _ _ _ _ _ id_info)
1226 = ASSERT(isDataCon id)
1227 case (arityMaybe (getInfo id_info)) of
1228 Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1231 isNullaryDataCon con = dataConArity con == 0 -- function of convenience
1233 addIdArity :: Id -> Int -> Id
1234 addIdArity (Id u n ty details pinfo info) arity
1235 = Id u n ty details pinfo (info `addInfo` (mkArityInfo arity))
1238 %************************************************************************
1240 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1242 %************************************************************************
1246 -> [StrictnessMark] -> [FieldLabel]
1247 -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1250 -- can get the tag and all the pieces of the type from the Type
1252 mkDataCon n stricts fields tvs ctxt args_tys tycon
1253 = ASSERT(length stricts == length args_tys)
1256 -- NB: data_con self-recursion; should be OK as tags are not
1257 -- looked at until late in the game.
1262 (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
1266 data_con_tag = position_within fIRST_TAG data_con_family
1268 data_con_family = tyConDataCons tycon
1270 position_within :: Int -> [Id] -> Int
1272 position_within acc (c:cs)
1273 = if c == data_con then acc else position_within (acc+1) cs
1275 position_within acc []
1276 = panic "mkDataCon: con not found in family"
1280 = mkSigmaTy tvs ctxt
1281 (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1283 datacon_info = noIdInfo `addInfo_UF` unfolding
1284 `addInfo` mkArityInfo arity
1285 --ToDo: `addInfo` specenv
1287 arity = length args_tys
1294 -- else -- do some business...
1296 (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1297 tyvar_tys = mkTyVarTys tyvars
1299 case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
1301 mkUnfolding EssentialUnfolding -- for data constructors
1302 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1305 mk_uf_bits tvs ctxt arg_tys tycon
1307 (inst_env, tyvars, tyvar_tys)
1308 = instantiateTyVarTemplates tvs
1311 -- the "context" and "arg_tys" have TyVarTemplates in them, so
1312 -- we instantiate those types to have the right TyVars in them
1314 case (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1315 of { inst_dict_tys ->
1316 case (map (instantiateTauTy inst_env) arg_tys) of { inst_arg_tys ->
1318 -- We can only have **ONE** call to mkTemplateLocals here;
1319 -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1320 -- (Mega-Sigh) [ToDo]
1321 case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars ->
1323 case (splitAt (length ctxt) all_vars) of { (dict_vars, vars) ->
1325 (tyvars, dict_vars, vars)
1328 -- these are really dubious Types, but they are only to make the
1329 -- binders for the lambdas for tossed-away dicts.
1330 ctxt_ty (clas, ty) = mkDictTy clas ty
1335 mkTupleCon :: Arity -> Id
1338 = Id unique n ty (TupleConId arity) NoPragmaInfo tuplecon_info
1340 n = mkTupleDataConName arity
1342 ty = mkSigmaTy tyvars []
1343 (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1344 tycon = mkTupleTyCon arity
1345 tyvars = take arity alphaTyVars
1346 tyvar_tys = mkTyVarTys tyvars
1349 = noIdInfo `addInfo_UF` unfolding
1350 `addInfo` mkArityInfo arity
1351 --LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1358 -- else -- do some business...
1360 (tyvars, dict_vars, vars) = mk_uf_bits arity
1361 tyvar_tys = mkTyVarTys tyvars
1363 case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
1365 EssentialUnfolding -- data constructors
1366 (mkLam tyvars (dict_vars ++ vars) plain_Con) }
1369 = case (mkTemplateLocals tyvar_tys) of { vars ->
1370 (tyvars, [], vars) }
1372 tyvar_tmpls = take arity alphaTyVars
1373 (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
1377 fIRST_TAG = 1 -- Tags allocated from here for real constructors
1381 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1382 dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _) _ _) = tag
1383 dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG
1384 dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
1386 dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
1387 dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
1388 dataConTyCon (Id _ _ _ (TupleConId a) _ _) = mkTupleTyCon a
1390 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1391 -- will panic if not a DataCon
1393 dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1394 = (tyvars, theta_ty, arg_tys, tycon)
1396 dataConSig (Id _ _ _ (TupleConId arity) _ _)
1397 = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1399 tyvars = take arity alphaTyVars
1400 tyvar_tys = mkTyVarTys tyvars
1402 dataConFieldLabels :: DataCon -> [FieldLabel]
1403 dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields
1404 dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = []
1406 dataConStrictMarks :: DataCon -> [StrictnessMark]
1407 dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts
1408 dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _)
1409 = nOfThem arity NotMarkedStrict
1411 dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
1412 dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
1414 dataConArgTys :: DataCon
1415 -> [Type] -- Instantiated at these types
1416 -> [Type] -- Needs arguments of these types
1417 dataConArgTys con_id inst_tys
1418 = map (instantiateTy tenv) arg_tys
1420 (tyvars, _, arg_tys, _) = dataConSig con_id
1421 tenv = zipEqual "dataConArgTys" tyvars inst_tys
1425 mkRecordSelId field_label selector_ty
1426 = Id (nameUnique name)
1429 (RecordSelId field_label)
1433 name = fieldLabelName field_label
1435 recordSelectorFieldLabel :: Id -> FieldLabel
1436 recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl
1440 Data type declarations are of the form:
1442 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1444 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1445 @C1 x y z@, we want a function binding:
1447 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1449 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1450 2nd-order polymorphic lambda calculus with explicit types.
1452 %************************************************************************
1454 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1456 %************************************************************************
1458 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1459 and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
1460 @TyVars@ don't really have to be new, because we are only producing a
1463 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1466 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1467 EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the
1468 example above: a, b, and x, y, z], which is enough (in the important
1469 \tr{DsExpr} case). (The middle set of @Ids@ is binders for any
1470 dictionaries, in the even of an overloaded data-constructor---none at
1474 getIdUnfolding :: Id -> UnfoldingDetails
1476 getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
1479 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1480 addIdUnfolding id@(Id u n ty info details) unfold_details
1482 case (isLocallyDefined id, unfold_details) of
1483 (_, NoUnfoldingDetails) -> True
1484 (True, IWantToBeINLINEd _) -> True
1485 (False, IWantToBeINLINEd _) -> False -- v bad
1489 Id u n ty (info `addInfo_UF` unfold_details) details
1493 In generating selector functions (take a dictionary, give back one
1494 component...), we need to what out for the nothing-to-select cases (in
1495 which case the ``selector'' is just an identity function):
1497 class Eq a => Foo a { } # the superdict selector for "Eq"
1499 class Foo a { op :: Complex b => c -> b -> a }
1500 # the method selector for "op";
1501 # note local polymorphism...
1504 %************************************************************************
1506 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1508 %************************************************************************
1511 getIdDemandInfo :: Id -> DemandInfo
1512 getIdDemandInfo (Id _ _ _ _ _ info) = getInfo info
1514 addIdDemandInfo :: Id -> DemandInfo -> Id
1515 addIdDemandInfo (Id u n ty details prags info) demand_info
1516 = Id u n ty details prags (info `addInfo` demand_info)
1520 getIdUpdateInfo :: Id -> UpdateInfo
1521 getIdUpdateInfo (Id _ _ _ _ _ info) = getInfo info
1523 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1524 addIdUpdateInfo (Id u n ty details prags info) upd_info
1525 = Id u n ty details prags (info `addInfo` upd_info)
1530 getIdArgUsageInfo :: Id -> ArgUsageInfo
1531 getIdArgUsageInfo (Id u n ty info details) = getInfo info
1533 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1534 addIdArgUsageInfo (Id u n ty info details) au_info
1535 = Id u n ty (info `addInfo` au_info) details
1541 getIdFBTypeInfo :: Id -> FBTypeInfo
1542 getIdFBTypeInfo (Id u n ty info details) = getInfo info
1544 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1545 addIdFBTypeInfo (Id u n ty info details) upd_info
1546 = Id u n ty (info `addInfo` upd_info) details
1552 getIdSpecialisation :: Id -> SpecEnv
1553 getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
1555 addIdSpecialisation :: Id -> SpecEnv -> Id
1556 addIdSpecialisation (Id u n ty details prags info) spec_info
1557 = Id u n ty details prags (info `addInfo` spec_info)
1561 Strictness: we snaffle the info out of the IdInfo.
1564 getIdStrictness :: Id -> StrictnessInfo
1566 getIdStrictness (Id _ _ _ _ _ info) = getInfo info
1568 addIdStrictness :: Id -> StrictnessInfo -> Id
1570 addIdStrictness (Id u n ty details prags info) strict_info
1571 = Id u n ty details prags (info `addInfo` strict_info)
1574 %************************************************************************
1576 \subsection[Id-comparison]{Comparison functions for @Id@s}
1578 %************************************************************************
1580 Comparison: equality and ordering---this stuff gets {\em hammered}.
1583 cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = cmp u1 u2
1584 -- short and very sweet
1588 instance Ord3 (GenId ty) where
1591 instance Eq (GenId ty) where
1592 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
1593 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
1595 instance Ord (GenId ty) where
1596 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
1597 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
1598 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
1599 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
1600 _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1603 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1604 account when comparing two data constructors. We need to do this
1605 because a specialised data constructor has the same Unique as its
1606 unspecialised counterpart.
1609 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1611 cmpId_withSpecDataCon id1 id2
1612 | eq_ids && isDataCon id1 && isDataCon id2
1613 = cmpEqDataCon id1 id2
1618 cmp_ids = cmpId id1 id2
1619 eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
1621 cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _)
1622 = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1624 cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_
1625 cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_
1626 cmpEqDataCon _ _ = EQ_
1629 %************************************************************************
1631 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1633 %************************************************************************
1636 instance Outputable ty => Outputable (GenId ty) where
1637 ppr sty id = pprId sty id
1639 -- and a SPECIALIZEd one:
1640 instance Outputable {-Id, i.e.:-}(GenId Type) where
1641 ppr sty id = pprId sty id
1643 showId :: PprStyle -> Id -> String
1644 showId sty id = ppShow 80 (pprId sty id)
1647 -- for DictFuns (instances) and const methods (instance code bits we
1648 -- can call directly): exported (a) if *either* the class or
1649 -- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
1650 -- class and tycon are from PreludeCore [non-std, but convenient]
1651 -- *and* the thing was defined in this module.
1653 instance_export_flag :: Class -> Type -> Bool -> ExportFlag
1655 instance_export_flag clas inst_ty from_here
1656 = panic "Id:instance_export_flag"
1658 = if instanceIsExported clas inst_ty from_here
1664 Default printing code (not used for interfaces):
1666 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1668 pprId sty (Id u n _ _ _ _) = ppr sty n
1669 -- WDP 96/05/06: We can re-elaborate this as we go along...
1673 idUnique (Id u _ _ _ _ _) = u
1675 instance Uniquable (GenId ty) where
1678 instance NamedThing (GenId ty) where
1679 getName this_id@(Id u n _ details _ _) = n
1684 get (SysLocalId _) = n
1685 get (SpecPragmaId _ _) = n
1689 get (InstId n _) = n
1690 get (DataConId _ _ _ _ _ _ _) = n
1691 get (TupleConId _) = n
1692 get (RecordSelId l) = getName l
1693 get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id)
1696 get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ???
1697 mod -> (mod, classOpString op)
1699 get (SpecId unspec ty_maybes _)
1700 = case moduleNamePair unspec of { (mod, unspec_nm) ->
1701 case specMaybeTysSuffix ty_maybes of { tys_suffix ->
1704 (if not (toplevelishId unspec)
1709 get (WorkerId unwrkr)
1710 = case moduleNamePair unwrkr of { (mod, unwrkr_nm) ->
1713 (if not (toplevelishId unwrkr)
1719 -- the remaining internally-generated flavours of
1720 -- Ids really do not have meaningful "original name" stuff,
1721 -- but we need to make up something (usually for debugging output)
1723 = case (getIdNamePieces True this_id) of { (piece1:pieces) ->
1724 case [ _CONS_ '.' p | p <- pieces ] of { dotted_pieces ->
1725 (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) }}
1729 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1730 the @Uniques@ out of local @Ids@ given to it.
1732 %************************************************************************
1734 \subsection{@IdEnv@s and @IdSet@s}
1736 %************************************************************************
1739 type IdEnv elt = UniqFM elt
1741 nullIdEnv :: IdEnv a
1743 mkIdEnv :: [(GenId ty, a)] -> IdEnv a
1744 unitIdEnv :: GenId ty -> a -> IdEnv a
1745 addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
1746 growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
1747 growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1749 delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
1750 delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
1751 combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1752 mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
1753 modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
1754 rngIdEnv :: IdEnv a -> [a]
1756 isNullIdEnv :: IdEnv a -> Bool
1757 lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
1758 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1762 addOneToIdEnv = addToUFM
1763 combineIdEnvs = plusUFM_C
1764 delManyFromIdEnv = delListFromUFM
1765 delOneFromIdEnv = delFromUFM
1767 lookupIdEnv = lookupUFM
1770 nullIdEnv = emptyUFM
1774 growIdEnvList env pairs = plusUFM env (listToUFM pairs)
1775 isNullIdEnv env = sizeUFM env == 0
1776 lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
1778 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1779 -- modify function, and put it back.
1781 modifyIdEnv env mangle_fn key
1782 = case (lookupIdEnv env key) of
1784 Just xx -> addOneToIdEnv env key (mangle_fn xx)
1788 type GenIdSet ty = UniqSet (GenId ty)
1789 type IdSet = UniqSet (GenId Type)
1791 emptyIdSet :: GenIdSet ty
1792 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1793 unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1794 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1795 idSetToList :: GenIdSet ty -> [GenId ty]
1796 unitIdSet :: GenId ty -> GenIdSet ty
1797 addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
1798 elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
1799 minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1800 isEmptyIdSet :: GenIdSet ty -> Bool
1801 mkIdSet :: [GenId ty] -> GenIdSet ty
1803 emptyIdSet = emptyUniqSet
1804 unitIdSet = unitUniqSet
1805 addOneToIdSet = addOneToUniqSet
1806 intersectIdSets = intersectUniqSets
1807 unionIdSets = unionUniqSets
1808 unionManyIdSets = unionManyUniqSets
1809 idSetToList = uniqSetToList
1810 elementOfIdSet = elementOfUniqSet
1811 minusIdSet = minusUniqSet
1812 isEmptyIdSet = isEmptyUniqSet
1817 addId, nmbrId :: Id -> NmbrM Id
1819 addId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1820 = case (lookupUFM_Directly idenv u) of
1821 Just xx -> _trace "addId: already in map!" $
1824 if toplevelishId id then
1825 _trace "addId: can't add toplevelish!" $
1827 else -- alloc a new unique for this guy
1828 -- and add an entry in the idenv
1829 -- NB: *** KNOT-TYING ***
1831 nenv_plus_id = NmbrEnv (incrUnique ui) ut uu
1832 (addToUFM_Directly idenv u new_id)
1835 (nenv2, new_ty) = nmbrType ty nenv_plus_id
1836 (nenv3, new_det) = nmbr_details det nenv2
1838 new_id = Id ui n new_ty new_det prag info
1842 nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1843 = case (lookupUFM_Directly idenv u) of
1844 Just xx -> (nenv, xx)
1846 if not (toplevelishId id) then
1847 _trace "nmbrId: lookup failed" $
1851 (nenv2, new_ty) = nmbrType ty nenv
1852 (nenv3, new_det) = nmbr_details det nenv2
1854 new_id = Id u n new_ty new_det prag info
1859 nmbr_details :: IdDetails -> NmbrM IdDetails
1861 nmbr_details (DataConId tag marks fields tvs theta arg_tys tc)
1862 = mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs ->
1863 mapNmbr nmbrField fields `thenNmbr` \ new_fields ->
1864 mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
1865 mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys ->
1866 returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_arg_tys tc)
1869 = --nmbrClass c `thenNmbr` \ new_c ->
1870 nmbrType t `thenNmbr` \ new_t ->
1871 returnNmbr (c, new_t)
1873 -- ToDo:add more cases as needed
1874 nmbr_details other_details = returnNmbr other_details
1877 nmbrField (FieldLabel n ty tag)
1878 = nmbrType ty `thenNmbr` \ new_ty ->
1879 returnNmbr (FieldLabel n new_ty tag)