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!
84 -- "Environments" keyed off of Ids, and sets of Ids
86 lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
87 growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
88 delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
91 -- and to make the interface self-sufficient...
92 GenIdSet(..), IdSet(..)
96 import IdLoop -- for paranoia checking
97 import TyLoop -- for paranoia checking
100 import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
101 import CStrings ( identToC, cSEP )
103 import Maybes ( maybeToBool )
104 import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
105 isLocallyDefinedName, isPreludeDefinedName,
106 mkTupleDataConName, mkCompoundName,
107 isLexSym, getLocalName,
108 isLocallyDefined, isPreludeDefined,
109 getOccName, moduleNamePair, origName, nameOf,
110 isExported, ExportFlag(..),
113 import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
114 import PragmaInfo ( PragmaInfo(..) )
115 import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
120 import SrcLoc ( mkBuiltinSrcLoc )
121 import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
122 import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
123 applyTyCon, isPrimType, instantiateTy,
124 tyVarsOfType, applyTypeEnvToTy, typePrimRep,
125 GenType, ThetaType(..), TauType(..), Type(..)
127 import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
129 import UniqSet -- practically all of it
130 import UniqSupply ( getBuiltinUniques )
131 import Unique ( pprUnique, showUnique,
132 Unique{-instance Ord3-}
134 import Util ( mapAccumL, nOfThem, zipEqual,
135 panic, panic#, pprPanic, assertPanic
139 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
142 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
143 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
144 strictness). The essential info about different kinds of @Ids@ is
147 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
151 Unique -- Key for fast comparison
152 ty -- Id's type; used all the time;
153 IdDetails -- Stuff about individual kinds of Ids.
154 PragmaInfo -- Properties of this Id requested by programmer
155 -- eg specialise-me, inline-me
156 IdInfo -- Properties of this Id deduced by compiler
160 data StrictnessMark = MarkedStrict | NotMarkedStrict
164 ---------------- Local values
166 = LocalId Name -- Local name; mentioned by the user
167 Bool -- True <=> no free type vars
169 | SysLocalId Name -- Local name; made up by the compiler
170 Bool -- as for LocalId
172 | SpecPragmaId Name -- Local name; introduced by the compiler
173 (Maybe Id) -- for explicit specid in pragma
174 Bool -- as for LocalId
176 ---------------- Global values
178 | ImportedId Name -- Global name (Imported or Implicit); Id imported from an interface
180 | PreludeId Name -- Global name (Builtin); Builtin prelude Ids
182 | TopLevId Name -- Global name (LocalDef); Top-level in the orig source pgm
183 -- (not moved there by transformations).
185 -- a TopLevId's type may contain free type variables, if
186 -- the monomorphism restriction applies.
188 ---------------- Data constructors
192 [StrictnessMark] -- Strict args; length = arity
193 [FieldLabel] -- Field labels for this constructor
195 [TyVar] [(Class,Type)] [Type] TyCon
197 -- forall tyvars . theta_ty =>
198 -- unitype_1 -> ... -> unitype_n -> tycon tyvars
203 | RecordSelId FieldLabel
205 ---------------- Things to do with overloading
207 | SuperDictSelId -- Selector for superclass dictionary
208 Class -- The class (input dict)
209 Class -- The superclass (result dict)
211 | MethodSelId Class -- An overloaded class operation, with
212 -- a fully polymorphic type. Its code
213 -- just selects a method from the
214 -- dictionary. The class.
215 ClassOp -- The operation
217 -- NB: The IdInfo for a MethodSelId has all the info about its
218 -- related "constant method Ids", which are just
219 -- specialisations of this general one.
221 | DefaultMethodId -- Default method for a particular class op
222 Class -- same class, <blah-blah> info as MethodSelId
223 ClassOp -- (surprise, surprise)
224 Bool -- True <=> I *know* this default method Id
225 -- is a generated one that just says
226 -- `error "No default method for <op>"'.
229 | DictFunId Class -- A DictFun is uniquely identified
230 Type -- by its class and type; this type has free type vars,
231 -- whose identity is irrelevant. Eg Class = Eq
233 -- The "a" is irrelevant. As it is too painful to
234 -- actually do comparisons that way, we kindly supply
235 -- a Unique for that purpose.
236 Bool -- True <=> from an instance decl in this mod
237 (Maybe Module) -- module where instance came from; Nothing => Prelude
240 | ConstMethodId -- A method which depends only on the type of the
241 -- instance, and not on any further dictionaries etc.
242 Class -- Uniquely identified by:
243 Type -- (class, type, classop) triple
245 Bool -- True => from an instance decl in this mod
246 (Maybe Module) -- module where instance came from; Nothing => Prelude
248 | InstId Name -- An instance of a dictionary, class operation,
249 -- or overloaded value (Local name)
250 Bool -- as for LocalId
252 | SpecId -- A specialisation of another Id
253 Id -- Id of which this is a specialisation
254 [Maybe Type] -- Types at which it is specialised;
255 -- A "Nothing" says this type ain't relevant.
256 Bool -- True <=> no free type vars; it's not enough
257 -- to know about the unspec version, because
258 -- we may specialise to a type w/ free tyvars
259 -- (i.e., in one of the "Maybe Type" dudes).
261 | WorkerId -- A "worker" for some other Id
262 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 ty d p i) = Id u (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
486 nested @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
502 chk (PreludeId _) = 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
524 chk (PreludeId _) = True
525 chk (TopLevId _) = 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 (InstId _ no_free_tvs) = no_free_tvs
533 chk (SpecId _ _ 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 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 _ _ False _) = 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 ty info (TopLevId fn))
849 = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
851 unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
852 = --false?: ASSERT(no_ftvs)
854 full_name = unlocaliseShortName mod u sn
856 Just (Id u ty info (TopLevId full_name))
858 unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
859 = --false?: on PreludeGlaST: ASSERT(no_ftvs)
861 full_name = unlocaliseShortName mod u sn
863 Just (Id u ty info (TopLevId full_name))
865 unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
866 = case unlocalise_parent mod u unspec of
868 Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))
870 unlocaliseId mod (Id u ty info (WorkerId unwrkr))
871 = case unlocalise_parent mod u unwrkr of
873 Just xx -> Just (Id u ty info (WorkerId xx))
875 unlocaliseId mod (Id u ty info (InstId name no_ftvs))
876 = Just (Id u ty info (TopLevId full_name))
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 _ ty info (LocalId sn no_ftvs))
890 = --false?: ASSERT(no_ftvs)
892 full_name = unlocaliseShortName mod uniq sn
894 Just (Id uniq ty info (TopLevId full_name))
896 unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
897 = --false?: ASSERT(no_ftvs)
899 full_name = unlocaliseShortName mod uniq sn
901 Just (Id uniq ty info (TopLevId full_name))
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)
934 apply_to_Id ty_fn (Id u ty details prag info)
938 Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
940 apply_to_details (SpecId unspec ty_maybes no_ftvs)
942 new_unspec = apply_to_Id ty_fn unspec
943 new_maybes = map apply_to_maybe ty_maybes
945 SpecId new_unspec new_maybes (no_free_tvs ty)
946 -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
948 apply_to_maybe Nothing = Nothing
949 apply_to_maybe (Just ty) = Just (ty_fn ty)
951 apply_to_details (WorkerId unwrkr)
953 new_unwrkr = apply_to_Id ty_fn unwrkr
957 apply_to_details other = other
960 Sadly, I don't think the one using the magic typechecker substitution
961 can be done with @apply_to_Id@. Here we go....
963 Strictness is very important here. We can't leave behind thunks
964 with pointers to the substitution: it {\em must} be single-threaded.
968 applySubstToId :: Subst -> Id -> (Subst, Id)
970 applySubstToId subst id@(Id u ty info details)
971 -- *cannot* have a "idHasNoFreeTyVars" get-out clause
972 -- because, in the typechecker, we are still
973 -- *concocting* the types.
974 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
975 case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
976 case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
977 (s4, Id u new_ty new_info new_details) }}}
979 apply_to_details subst _ (InstId inst no_ftvs)
980 = case (applySubstToInst subst inst) of { (s2, new_inst) ->
981 (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
983 apply_to_details subst new_ty (SpecId unspec ty_maybes _)
984 = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
985 case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
986 (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
987 -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
989 apply_to_maybe subst Nothing = (subst, Nothing)
990 apply_to_maybe subst (Just ty)
991 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
994 apply_to_details subst _ (WorkerId unwrkr)
995 = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
996 (s2, WorkerId new_unwrkr) }
998 apply_to_details subst _ other = (subst, other)
1003 getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
1005 getIdNamePieces show_uniqs id
1006 = get (unsafeGenId2Id id)
1008 get (Id u _ details _ _)
1010 DataConId n _ _ _ _ _ _ _ ->
1011 case (moduleNamePair n) of { (mod, name) ->
1012 if isPreludeDefinedName n then [name] else [mod, name] }
1014 TupleConId n _ -> [nameOf (origName n)]
1017 let n = fieldLabelName lbl
1019 case (moduleNamePair n) of { (mod, name) ->
1020 if isPreludeDefinedName n then [name] else [mod, name] }
1022 ImportedId n -> get_fullname_pieces n
1023 PreludeId n -> get_fullname_pieces n
1024 TopLevId n -> get_fullname_pieces n
1026 SuperDictSelId c sc ->
1027 case (moduleNamePair c) of { (c_mod, c_name) ->
1028 case (moduleNamePair sc) of { (sc_mod, sc_name) ->
1030 c_bits = if isPreludeDefined c
1032 else [c_mod, c_name]
1034 sc_bits= if isPreludeDefined sc
1036 else [sc_mod, sc_name]
1038 [SLIT("sdsel")] ++ c_bits ++ sc_bits }}
1040 MethodSelId clas op ->
1041 case (moduleNamePair clas) of { (c_mod, c_name) ->
1042 case (getClassOpString op) of { op_name ->
1043 if isPreludeDefined clas
1045 else [c_mod, c_name, op_name]
1048 DefaultMethodId clas op _ ->
1049 case (moduleNamePair clas) of { (c_mod, c_name) ->
1050 case (getClassOpString op) of { op_name ->
1051 if isPreludeDefined clas
1052 then [SLIT("defm"), op_name]
1053 else [SLIT("defm"), c_mod, c_name, op_name] }}
1055 DictFunId c ty _ _ ->
1056 case (moduleNamePair c) of { (c_mod, c_name) ->
1058 c_bits = if isPreludeDefined c
1060 else [c_mod, c_name]
1062 ty_bits = getTypeString ty
1064 [SLIT("dfun")] ++ c_bits ++ ty_bits }
1066 ConstMethodId c ty o _ _ ->
1067 case (moduleNamePair c) of { (c_mod, c_name) ->
1068 case (getTypeString ty) of { ty_bits ->
1069 case (getClassOpString o) of { o_name ->
1070 case (if isPreludeDefined c
1072 else [c_mod, c_name]) of { c_bits ->
1073 [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
1075 -- if the unspecialised equiv is "top-level",
1076 -- the name must be concocted from its name and the
1077 -- names of the types to which specialised...
1079 SpecId unspec ty_maybes _ ->
1080 get unspec ++ (if not (toplevelishId unspec)
1082 else concat (map typeMaybeString ty_maybes))
1085 get unwrkr ++ (if not (toplevelishId unwrkr)
1089 LocalId n _ -> let local = getLocalName n in
1090 if show_uniqs then [local, showUnique u] else [local]
1091 InstId n _ -> [getLocalName n, showUnique u]
1092 SysLocalId n _ -> [getLocalName n, showUnique u]
1093 SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
1095 get_fullname_pieces :: Name -> [FAST_STRING]
1096 get_fullname_pieces n
1097 = BIND (moduleNamePair n) _TO_ (mod, name) ->
1098 if isPreludeDefinedName n
1104 %************************************************************************
1106 \subsection[Id-type-funs]{Type-related @Id@ functions}
1108 %************************************************************************
1111 idType :: GenId ty -> ty
1113 idType (Id _ ty _ _ _) = ty
1118 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1120 getMentionedTyConsAndClassesFromId id
1121 = getMentionedTyConsAndClassesFromType (idType id)
1126 idPrimRep i = typePrimRep (idType i)
1131 getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
1132 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
1133 getInstIdModule other = panic "Id:getInstIdModule"
1137 %************************************************************************
1139 \subsection[Id-overloading]{Functions related to overloading}
1141 %************************************************************************
1144 mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
1145 mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
1146 mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
1148 mkDictFunId u c ity full_ty from_here mod info
1149 = Id u full_ty (DictFunId c ity from_here mod) NoPragmaInfo info
1151 mkConstMethodId u c op ity full_ty from_here mod info
1152 = Id u full_ty (ConstMethodId c ity op from_here mod) NoPragmaInfo info
1154 mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
1156 mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo
1159 getConstMethodId clas op ty
1160 = -- constant-method info is hidden in the IdInfo of
1161 -- the class-op id (as mentioned up above).
1163 sel_id = getMethodSelId clas op
1165 case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1167 Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
1168 ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1169 ppr PprDebug sel_id],
1170 ppStr "(This can arise if an interface pragma refers to an instance",
1171 ppStr "but there is no imported interface which *defines* that instance.",
1172 ppStr "The info above, however ugly, should indicate what else you need to import."
1177 %************************************************************************
1179 \subsection[local-funs]{@LocalId@-related functions}
1181 %************************************************************************
1184 mkImported n ty info = Id (nameUnique n) ty (ImportedId n) NoPragmaInfo info
1185 mkPreludeId n ty info = Id (nameUnique n) ty (PreludeId n) NoPragmaInfo info
1188 updateIdType :: Id -> Type -> Id
1189 updateIdType (Id u _ info details) ty = Id u ty info details
1194 type MyTy a b = GenType (GenTyVar a) b
1195 type MyId a b = GenId (MyTy a b)
1197 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1199 -- SysLocal: for an Id being created by the compiler out of thin air...
1200 -- UserLocal: an Id with a name the user might recognize...
1201 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1203 mkSysLocal str uniq ty loc
1204 = Id uniq ty (SysLocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1206 mkUserLocal str uniq ty loc
1207 = Id uniq ty (LocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1209 -- mkUserId builds a local or top-level Id, depending on the name given
1210 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1211 mkUserId name ty pragma_info
1213 = Id (nameUnique name) ty (LocalId name (no_free_tvs ty)) pragma_info noIdInfo
1215 = Id (nameUnique name) ty
1216 (if isLocallyDefinedName name then TopLevId name else ImportedId name)
1217 pragma_info noIdInfo
1224 -- for a SpecPragmaId being created by the compiler out of thin air...
1225 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1226 mkSpecPragmaId str uniq ty specid loc
1227 = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
1230 mkSpecId u unspec ty_maybes ty info
1231 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1232 Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1234 -- Specialised version of constructor: only used in STG and code generation
1235 -- Note: The specialsied Id has the same unique as the unspeced Id
1237 mkSameSpecCon ty_maybes unspec@(Id u ty info details)
1238 = ASSERT(isDataCon unspec)
1239 ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1240 Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1242 new_ty = specialiseTy ty ty_maybes 0
1244 localiseId :: Id -> Id
1245 localiseId id@(Id u ty info details)
1246 = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
1248 name = getOccName id
1252 mkIdWithNewUniq :: Id -> Unique -> Id
1254 mkIdWithNewUniq (Id _ ty details prag info) uniq
1255 = Id uniq ty details prag info
1258 Make some local @Ids@ for a template @CoreExpr@. These have bogus
1259 @Uniques@, but that's OK because the templates are supposed to be
1260 instantiated before use.
1262 mkTemplateLocals :: [Type] -> [Id]
1263 mkTemplateLocals tys
1264 = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1265 (getBuiltinUniques (length tys))
1270 getIdInfo :: GenId ty -> IdInfo
1271 getPragmaInfo :: GenId ty -> PragmaInfo
1273 getIdInfo (Id _ _ _ _ info) = info
1274 getPragmaInfo (Id _ _ _ info _) = info
1277 replaceIdInfo :: Id -> IdInfo -> Id
1279 replaceIdInfo (Id u ty _ details) info = Id u ty info details
1281 selectIdInfoForSpecId :: Id -> IdInfo
1282 selectIdInfoForSpecId unspec
1283 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1284 noIdInfo `addInfo_UF` getIdUnfolding unspec
1288 %************************************************************************
1290 \subsection[Id-arities]{Arity-related functions}
1292 %************************************************************************
1294 For locally-defined Ids, the code generator maintains its own notion
1295 of their arities; so it should not be asking... (but other things
1296 besides the code-generator need arity info!)
1299 getIdArity :: Id -> ArityInfo
1300 getIdArity (Id _ _ _ _ id_info) = getInfo id_info
1302 dataConArity :: DataCon -> Int
1303 dataConArity id@(Id _ _ _ _ id_info)
1304 = ASSERT(isDataCon id)
1305 case (arityMaybe (getInfo id_info)) of
1306 Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1309 addIdArity :: Id -> Int -> Id
1310 addIdArity (Id u ty details pinfo info) arity
1311 = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
1314 %************************************************************************
1316 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1318 %************************************************************************
1322 -> [StrictnessMark] -> [FieldLabel]
1323 -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1326 -- can get the tag and all the pieces of the type from the Type
1328 mkDataCon n stricts fields tvs ctxt args_tys tycon
1329 = ASSERT(length stricts == length args_tys)
1332 -- NB: data_con self-recursion; should be OK as tags are not
1333 -- looked at until late in the game.
1337 (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon)
1341 data_con_tag = position_within fIRST_TAG data_con_family
1343 data_con_family = tyConDataCons tycon
1345 position_within :: Int -> [Id] -> Int
1347 position_within acc (c:cs)
1348 = if c == data_con then acc else position_within (acc+1) cs
1350 position_within acc []
1351 = panic "mkDataCon: con not found in family"
1355 = mkSigmaTy tvs ctxt
1356 (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1358 datacon_info = noIdInfo `addInfo_UF` unfolding
1359 `addInfo` mkArityInfo arity
1360 --ToDo: `addInfo` specenv
1362 arity = length args_tys
1369 -- else -- do some business...
1371 (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1372 tyvar_tys = mkTyVarTys tyvars
1374 BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1376 mkUnfolding EssentialUnfolding -- for data constructors
1377 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1380 mk_uf_bits tvs ctxt arg_tys tycon
1382 (inst_env, tyvars, tyvar_tys)
1383 = instantiateTyVarTemplates tvs
1386 -- the "context" and "arg_tys" have TyVarTemplates in them, so
1387 -- we instantiate those types to have the right TyVars in them
1389 BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1390 _TO_ inst_dict_tys ->
1391 BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys ->
1393 -- We can only have **ONE** call to mkTemplateLocals here;
1394 -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1395 -- (Mega-Sigh) [ToDo]
1396 BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
1398 BIND (splitAt (length ctxt) all_vars) _TO_ (dict_vars, vars) ->
1400 (tyvars, dict_vars, vars)
1403 -- these are really dubious Types, but they are only to make the
1404 -- binders for the lambdas for tossed-away dicts.
1405 ctxt_ty (clas, ty) = mkDictTy clas ty
1410 mkTupleCon :: Arity -> Id
1413 = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info
1415 n = mkTupleDataConName arity
1417 ty = mkSigmaTy tyvars []
1418 (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1419 tycon = mkTupleTyCon arity
1420 tyvars = take arity alphaTyVars
1421 tyvar_tys = mkTyVarTys tyvars
1424 = noIdInfo `addInfo_UF` unfolding
1425 `addInfo` mkArityInfo arity
1426 --LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1433 -- else -- do some business...
1435 (tyvars, dict_vars, vars) = mk_uf_bits arity
1436 tyvar_tys = mkTyVarTys tyvars
1438 BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1441 EssentialUnfolding -- data constructors
1442 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1446 = BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
1450 tyvar_tmpls = take arity alphaTyVars
1451 (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
1455 fIRST_TAG = 1 -- Tags allocated from here for real constructors
1459 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1460 dataConTag (Id _ _ (DataConId _ tag _ _ _ _ _ _) _ _) = tag
1461 dataConTag (Id _ _ (TupleConId _ _) _ _) = fIRST_TAG
1462 dataConTag (Id _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
1464 dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
1465 dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon
1466 dataConTyCon (Id _ _ (TupleConId _ a) _ _) = mkTupleTyCon a
1468 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1469 -- will panic if not a DataCon
1471 dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1472 = (tyvars, theta_ty, arg_tys, tycon)
1474 dataConSig (Id _ _ (TupleConId _ arity) _ _)
1475 = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1477 tyvars = take arity alphaTyVars
1478 tyvar_tys = mkTyVarTys tyvars
1480 dataConFieldLabels :: DataCon -> [FieldLabel]
1481 dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields
1482 dataConFieldLabels (Id _ _ (TupleConId _ _) _ _) = []
1484 dataConStrictMarks :: DataCon -> [StrictnessMark]
1485 dataConStrictMarks (Id _ _ (DataConId _ _ stricts _ _ _ _ _) _ _) = stricts
1486 dataConStrictMarks (Id _ _ (TupleConId _ arity) _ _)
1487 = take arity (repeat NotMarkedStrict)
1489 dataConArgTys :: DataCon
1490 -> [Type] -- Instantiated at these types
1491 -> [Type] -- Needs arguments of these types
1492 dataConArgTys con_id inst_tys
1493 = map (instantiateTy tenv) arg_tys
1495 (tyvars, _, arg_tys, _) = dataConSig con_id
1496 tenv = tyvars `zipEqual` inst_tys
1500 mkRecordSelId field_label selector_ty
1501 = Id (nameUnique name)
1503 (RecordSelId field_label)
1507 name = fieldLabelName field_label
1509 recordSelectorFieldLabel :: Id -> FieldLabel
1510 recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl
1514 Data type declarations are of the form:
1516 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1518 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1519 @C1 x y z@, we want a function binding:
1521 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1523 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1524 2nd-order polymorphic lambda calculus with explicit types.
1526 %************************************************************************
1528 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1530 %************************************************************************
1532 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1533 and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
1534 @TyVars@ don't really have to be new, because we are only producing a
1537 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1540 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1541 EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the
1542 example above: a, b, and x, y, z], which is enough (in the important
1543 \tr{DsExpr} case). (The middle set of @Ids@ is binders for any
1544 dictionaries, in the even of an overloaded data-constructor---none at
1548 getIdUnfolding :: Id -> UnfoldingDetails
1550 getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info
1553 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1554 addIdUnfolding id@(Id u ty info details) unfold_details
1556 case (isLocallyDefined id, unfold_details) of
1557 (_, NoUnfoldingDetails) -> True
1558 (True, IWantToBeINLINEd _) -> True
1559 (False, IWantToBeINLINEd _) -> False -- v bad
1563 Id u ty (info `addInfo_UF` unfold_details) details
1567 In generating selector functions (take a dictionary, give back one
1568 component...), we need to what out for the nothing-to-select cases (in
1569 which case the ``selector'' is just an identity function):
1571 class Eq a => Foo a { } # the superdict selector for "Eq"
1573 class Foo a { op :: Complex b => c -> b -> a }
1574 # the method selector for "op";
1575 # note local polymorphism...
1578 %************************************************************************
1580 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1582 %************************************************************************
1585 getIdDemandInfo :: Id -> DemandInfo
1586 getIdDemandInfo (Id _ _ _ _ info) = getInfo info
1588 addIdDemandInfo :: Id -> DemandInfo -> Id
1589 addIdDemandInfo (Id u ty details prags info) demand_info
1590 = Id u ty details prags (info `addInfo` demand_info)
1594 getIdUpdateInfo :: Id -> UpdateInfo
1595 getIdUpdateInfo (Id _ _ _ _ info) = getInfo info
1597 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1598 addIdUpdateInfo (Id u ty details prags info) upd_info
1599 = Id u ty details prags (info `addInfo` upd_info)
1604 getIdArgUsageInfo :: Id -> ArgUsageInfo
1605 getIdArgUsageInfo (Id u ty info details) = getInfo info
1607 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1608 addIdArgUsageInfo (Id u ty info details) au_info
1609 = Id u ty (info `addInfo` au_info) details
1615 getIdFBTypeInfo :: Id -> FBTypeInfo
1616 getIdFBTypeInfo (Id u ty info details) = getInfo info
1618 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1619 addIdFBTypeInfo (Id u ty info details) upd_info
1620 = Id u ty (info `addInfo` upd_info) details
1626 getIdSpecialisation :: Id -> SpecEnv
1627 getIdSpecialisation (Id _ _ _ _ info) = getInfo info
1629 addIdSpecialisation :: Id -> SpecEnv -> Id
1630 addIdSpecialisation (Id u ty details prags info) spec_info
1631 = Id u ty details prags (info `addInfo` spec_info)
1635 Strictness: we snaffle the info out of the IdInfo.
1638 getIdStrictness :: Id -> StrictnessInfo
1640 getIdStrictness (Id _ _ _ _ info) = getInfo info
1642 addIdStrictness :: Id -> StrictnessInfo -> Id
1644 addIdStrictness (Id u ty details prags info) strict_info
1645 = Id u ty details prags (info `addInfo` strict_info)
1648 %************************************************************************
1650 \subsection[Id-comparison]{Comparison functions for @Id@s}
1652 %************************************************************************
1654 Comparison: equality and ordering---this stuff gets {\em hammered}.
1657 cmpId (Id u1 _ _ _ _) (Id u2 _ _ _ _) = cmp u1 u2
1658 -- short and very sweet
1662 instance Ord3 (GenId ty) where
1665 instance Eq (GenId ty) where
1666 a == b = case cmpId a b of { EQ_ -> True; _ -> False }
1667 a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
1669 instance Ord (GenId ty) where
1670 a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
1671 a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
1672 a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
1673 a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
1674 _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1677 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1678 account when comparing two data constructors. We need to do this
1679 because a specialised data constructor has the same Unique as its
1680 unspecialised counterpart.
1683 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1685 cmpId_withSpecDataCon id1 id2
1686 | eq_ids && isDataCon id1 && isDataCon id2
1687 = cmpEqDataCon id1 id2
1692 cmp_ids = cmpId id1 id2
1693 eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
1695 cmpEqDataCon (Id _ _ (SpecId _ mtys1 _) _ _) (Id _ _ (SpecId _ mtys2 _) _ _)
1696 = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1698 cmpEqDataCon _ (Id _ _ (SpecId _ _ _) _ _) = LT_
1699 cmpEqDataCon (Id _ _ (SpecId _ _ _) _ _) _ = GT_
1700 cmpEqDataCon _ _ = EQ_
1703 %************************************************************************
1705 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1707 %************************************************************************
1710 instance Outputable ty => Outputable (GenId ty) where
1711 ppr sty id = pprId sty id
1713 -- and a SPECIALIZEd one:
1714 instance Outputable {-Id, i.e.:-}(GenId Type) where
1715 ppr sty id = pprId sty id
1717 showId :: PprStyle -> Id -> String
1718 showId sty id = ppShow 80 (pprId sty id)
1721 -- for DictFuns (instances) and const methods (instance code bits we
1722 -- can call directly): exported (a) if *either* the class or
1723 -- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
1724 -- class and tycon are from PreludeCore [non-std, but convenient]
1725 -- *and* the thing was defined in this module.
1727 instance_export_flag :: Class -> Type -> Bool -> ExportFlag
1729 instance_export_flag clas inst_ty from_here
1730 = panic "Id:instance_export_flag"
1732 = if instanceIsExported clas inst_ty from_here
1738 Default printing code (not used for interfaces):
1740 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1744 pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
1748 pieces_to_print -- maybe use Unique only
1749 = if isSysLocalId id then tail pieces else pieces
1751 ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
1755 PprForAsm _ _ -> for_code
1756 PprInterface -> ppr other_sty occur_name
1757 PprForUser -> ppr other_sty occur_name
1758 PprUnfolding -> qualified_name pieces
1759 PprDebug -> qualified_name pieces
1760 PprShowAll -> ppBesides [qualified_name pieces,
1763 ppr other_sty (idType id),
1764 ppIdInfo other_sty (unsafeGenId2Id id) True
1765 (\x->x) nullIdEnv (getIdInfo id),
1766 ppPStr SLIT("-}") ])]
1768 occur_name = getOccName id `appendRdr`
1769 (if not (isSysLocalId id)
1771 else SLIT(".") _APPEND_ (showUnique (idUnique id)))
1773 qualified_name pieces
1774 = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
1776 pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add
1777 pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = ppNil
1778 pp_uniq (Id _ _ (TupleConId _ _) _ _) = ppNil
1779 pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere
1780 pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil
1781 pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil
1782 pp_uniq (Id _ _ (InstId _ _) _ _) = ppNil
1783 pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (idUnique other_id), ppPStr SLIT("-}")]
1785 -- print PprDebug Ids with # afterwards if they are of primitive type.
1786 pp_ubxd pretty = pretty
1788 {- LATER: applying isPrimType restricts type
1789 pp_ubxd pretty = if isPrimType (idType id)
1790 then ppBeside pretty (ppChar '#')
1797 idUnique (Id u _ _ _ _) = u
1799 instance Uniquable (GenId ty) where
1802 instance NamedThing (GenId ty) where
1803 getName this_id@(Id u _ details _ _)
1806 get (LocalId n _) = n
1807 get (SysLocalId n _) = n
1808 get (SpecPragmaId n _ _) = n
1809 get (ImportedId n) = n
1810 get (PreludeId n) = n
1811 get (TopLevId n) = n
1812 get (InstId n _) = n
1813 get (DataConId n _ _ _ _ _ _ _) = n
1814 get (TupleConId n _) = n
1815 get (RecordSelId l) = getName l
1816 get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id)
1819 get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ???
1820 mod -> (mod, getClassOpString op)
1822 get (SpecId unspec ty_maybes _)
1823 = BIND moduleNamePair unspec _TO_ (mod, unspec_nm) ->
1824 BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
1827 (if not (toplevelishId unspec)
1833 get (WorkerId unwrkr)
1834 = BIND moduleNamePair unwrkr _TO_ (mod, unwrkr_nm) ->
1837 (if not (toplevelishId unwrkr)
1844 -- the remaining internally-generated flavours of
1845 -- Ids really do not have meaningful "original name" stuff,
1846 -- but we need to make up something (usually for debugging output)
1848 = BIND (getIdNamePieces True this_id) _TO_ (piece1:pieces) ->
1849 BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
1850 (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
1855 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1856 the @Uniques@ out of local @Ids@ given to it.
1858 %************************************************************************
1860 \subsection{@IdEnv@s and @IdSet@s}
1862 %************************************************************************
1865 type IdEnv elt = UniqFM elt
1867 nullIdEnv :: IdEnv a
1869 mkIdEnv :: [(GenId ty, a)] -> IdEnv a
1870 unitIdEnv :: GenId ty -> a -> IdEnv a
1871 addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
1872 growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
1873 growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1875 delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
1876 delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
1877 combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1878 mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
1879 modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
1880 rngIdEnv :: IdEnv a -> [a]
1882 isNullIdEnv :: IdEnv a -> Bool
1883 lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
1884 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1888 addOneToIdEnv = addToUFM
1889 combineIdEnvs = plusUFM_C
1890 delManyFromIdEnv = delListFromUFM
1891 delOneFromIdEnv = delFromUFM
1893 lookupIdEnv = lookupUFM
1896 nullIdEnv = emptyUFM
1900 growIdEnvList env pairs = plusUFM env (listToUFM pairs)
1901 isNullIdEnv env = sizeUFM env == 0
1902 lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
1904 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1905 -- modify function, and put it back.
1907 modifyIdEnv env mangle_fn key
1908 = case (lookupIdEnv env key) of
1910 Just xx -> addOneToIdEnv env key (mangle_fn xx)
1914 type GenIdSet ty = UniqSet (GenId ty)
1915 type IdSet = UniqSet (GenId Type)
1917 emptyIdSet :: GenIdSet ty
1918 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1919 unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1920 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1921 idSetToList :: GenIdSet ty -> [GenId ty]
1922 unitIdSet :: GenId ty -> GenIdSet ty
1923 addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
1924 elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
1925 minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1926 isEmptyIdSet :: GenIdSet ty -> Bool
1927 mkIdSet :: [GenId ty] -> GenIdSet ty
1929 emptyIdSet = emptyUniqSet
1930 unitIdSet = unitUniqSet
1931 addOneToIdSet = addOneToUniqSet
1932 intersectIdSets = intersectUniqSets
1933 unionIdSets = unionUniqSets
1934 unionManyIdSets = unionManyUniqSets
1935 idSetToList = uniqSetToList
1936 elementOfIdSet = elementOfUniqSet
1937 minusIdSet = minusUniqSet
1938 isEmptyIdSet = isEmptyUniqSet