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,
39 dataConSig, getInstantiatedDataConSig,
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
98 import NameLoop -- for paranoia checking
101 import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
102 import CStrings ( identToC, cSEP )
104 import Maybes ( maybeToBool )
105 import NameTypes ( mkShortName, fromPrelude, FullName, ShortName )
106 import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
107 import Name ( Name(..) )
108 import Outputable ( isAvarop, isAconop, getLocalName,
109 isExported, ExportFlag(..) )
110 import PragmaInfo ( PragmaInfo(..) )
111 import PrelMods ( pRELUDE_BUILTIN )
112 import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
117 import SrcLoc ( mkBuiltinSrcLoc )
118 import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
119 import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
120 applyTyCon, isPrimType, instantiateTy,
121 tyVarsOfType, applyTypeEnvToTy, typePrimRep,
122 GenType, ThetaType(..), TauType(..), Type(..)
124 import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
126 import UniqSet -- practically all of it
127 import UniqSupply ( getBuiltinUniques )
128 import Unique ( mkTupleDataConUnique, pprUnique, showUnique,
129 Unique{-instance Ord3-}
131 import Util ( mapAccumL, nOfThem,
132 panic, panic#, pprPanic, assertPanic
136 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
139 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
140 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
141 strictness). The essential info about different kinds of @Ids@ is
144 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
148 Unique -- Key for fast comparison
149 ty -- Id's type; used all the time;
150 IdDetails -- Stuff about individual kinds of Ids.
151 PragmaInfo -- Properties of this Id requested by programmer
152 -- eg specialise-me, inline-me
153 IdInfo -- Properties of this Id deduced by compiler
157 data StrictnessMark = MarkedStrict | NotMarkedStrict
161 ---------------- Local values
163 = LocalId ShortName -- mentioned by the user
164 Bool -- True <=> no free type vars
166 | SysLocalId ShortName -- made up by the compiler
167 Bool -- as for LocalId
169 | SpecPragmaId ShortName -- introduced by the compiler
170 (Maybe Id) -- for explicit specid in pragma
171 Bool -- as for LocalId
173 ---------------- Global values
175 | ImportedId FullName -- Id imported from an interface
177 | PreludeId FullName -- things < Prelude that compiler "knows" about
179 | TopLevId FullName -- Top-level in the orig source pgm
180 -- (not moved there by transformations).
182 -- a TopLevId's type may contain free type variables, if
183 -- the monomorphism restriction applies.
185 ---------------- Data constructors
189 [StrictnessMark] -- Strict args; length = arity
190 [FieldLabel] -- Field labels for this constructor
192 [TyVar] [(Class,Type)] [Type] TyCon
194 -- forall tyvars . theta_ty =>
195 -- unitype_1 -> ... -> unitype_n -> tycon tyvars
197 | TupleConId Int -- Its arity
199 | RecordSelectorId FieldLabel
201 ---------------- Things to do with overloading
203 | SuperDictSelId -- Selector for superclass dictionary
204 Class -- The class (input dict)
205 Class -- The superclass (result dict)
207 | MethodSelId Class -- An overloaded class operation, with
208 -- a fully polymorphic type. Its code
209 -- just selects a method from the
210 -- dictionary. The class.
211 ClassOp -- The operation
213 -- NB: The IdInfo for a MethodSelId has all the info about its
214 -- related "constant method Ids", which are just
215 -- specialisations of this general one.
217 | DefaultMethodId -- Default method for a particular class op
218 Class -- same class, <blah-blah> info as MethodSelId
219 ClassOp -- (surprise, surprise)
220 Bool -- True <=> I *know* this default method Id
221 -- is a generated one that just says
222 -- `error "No default method for <op>"'.
225 | DictFunId Class -- A DictFun is uniquely identified
226 Type -- by its class and type; this type has free type vars,
227 -- whose identity is irrelevant. Eg Class = Eq
229 -- The "a" is irrelevant. As it is too painful to
230 -- actually do comparisons that way, we kindly supply
231 -- a Unique for that purpose.
232 Bool -- True <=> from an instance decl in this mod
233 FAST_STRING -- module where instance came from
236 | ConstMethodId -- A method which depends only on the type of the
237 -- instance, and not on any further dictionaries etc.
238 Class -- Uniquely identified by:
239 Type -- (class, type, classop) triple
241 Bool -- True <=> from an instance decl in this mod
242 FAST_STRING -- module where instance came from
244 | InstId ShortName -- An instance of a dictionary, class operation,
245 -- or overloaded value
246 Bool -- as for LocalId
248 | SpecId -- A specialisation of another Id
249 Id -- Id of which this is a specialisation
250 [Maybe Type] -- Types at which it is specialised;
251 -- A "Nothing" says this type ain't relevant.
252 Bool -- True <=> no free type vars; it's not enough
253 -- to know about the unspec version, because
254 -- we may specialise to a type w/ free tyvars
255 -- (i.e., in one of the "Maybe Type" dudes).
257 | WorkerId -- A "worker" for some other Id
258 Id -- Id for which this is a worker
268 DictFunIds are generated from instance decls.
273 instance Foo a => Foo [a] where
276 generates the dict fun id decl
278 dfun.Foo.[*] = \d -> ...
280 The dfun id is uniquely named by the (class, type) pair. Notice, it
281 isn't a (class,tycon) pair any more, because we may get manually or
282 automatically generated specialisations of the instance decl:
284 instance Foo [Int] where
291 The type variables in the name are irrelevant; we print them as stars.
294 Constant method ids are generated from instance decls where
295 there is no context; that is, no dictionaries are needed to
296 construct the method. Example
298 instance Foo Int where
301 Then we get a constant method
306 It is possible, albeit unusual, to have a constant method
307 for an instance decl which has type vars:
309 instance Foo [a] where
313 We get the constant method
317 So a constant method is identified by a class/op/type triple.
318 The type variables in the type are irrelevant.
321 For Ids whose names must be known/deducible in other modules, we have
322 to conjure up their worker's names (and their worker's worker's
323 names... etc) in a known systematic way.
326 %************************************************************************
328 \subsection[Id-documentation]{Documentation}
330 %************************************************************************
334 The @Id@ datatype describes {\em values}. The basic things we want to
335 know: (1)~a value's {\em type} (@idType@ is a very common
336 operation in the compiler); and (2)~what ``flavour'' of value it might
337 be---for example, it can be terribly useful to know that a value is a
341 %----------------------------------------------------------------------
342 \item[@DataConId@:] For the data constructors declared by a @data@
343 declaration. Their type is kept in {\em two} forms---as a regular
344 @Type@ (in the usual place), and also in its constituent pieces (in
345 the ``details''). We are frequently interested in those pieces.
347 %----------------------------------------------------------------------
348 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
349 the infinite family of tuples.
351 %----------------------------------------------------------------------
352 \item[@ImportedId@:] These are values defined outside this module.
353 {\em Everything} we want to know about them must be stored here (or in
356 %----------------------------------------------------------------------
357 \item[@PreludeId@:] ToDo
359 %----------------------------------------------------------------------
360 \item[@TopLevId@:] These are values defined at the top-level in this
361 module; i.e., those which {\em might} be exported (hence, a
362 @FullName@). It does {\em not} include those which are moved to the
363 top-level through program transformations.
365 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
366 Theoretically, they could be floated inwards, but there's no known
367 advantage in doing so. This way, we can keep them with the same
368 @Unique@ throughout (no cloning), and, in general, we don't have to be
369 so paranoid about them.
371 In particular, we had the following problem generating an interface:
372 We have to ``stitch together'' info (1)~from the typechecker-produced
373 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
374 what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change}
375 between (1) and (2), you're sunk!
377 %----------------------------------------------------------------------
378 \item[@MethodSelId@:] A selector from a dictionary; it may select either
379 a method or a dictionary for one of the class's superclasses.
381 %----------------------------------------------------------------------
384 @mkDictFunId [a,b..] theta C T@ is the function derived from the
387 instance theta => C (T a b ..) where
390 It builds function @Id@ which maps dictionaries for theta,
391 to a dictionary for C (T a b ..).
393 *Note* that with the ``Mark Jones optimisation'', the theta may
394 include dictionaries for the immediate superclasses of C at the type
397 %----------------------------------------------------------------------
400 %----------------------------------------------------------------------
403 %----------------------------------------------------------------------
406 %----------------------------------------------------------------------
407 \item[@LocalId@:] A purely-local value, e.g., a function argument,
408 something defined in a @where@ clauses, ... --- but which appears in
409 the original program text.
411 %----------------------------------------------------------------------
412 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
413 the original program text; these are introduced by the compiler in
416 %----------------------------------------------------------------------
417 \item[@SpecPragmaId@:] Introduced by the compiler to record
418 Specialisation pragmas. It is dead code which MUST NOT be removed
419 before specialisation.
424 %----------------------------------------------------------------------
427 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
428 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
432 They have no free type variables, so if you are making a
433 type-variable substitution you don't need to look inside them.
435 They are constants, so they are not free variables. (When the STG
436 machine makes a closure, it puts all the free variables in the
437 closure; the above are not required.)
439 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
440 properties, but they may not.
443 %************************************************************************
445 \subsection[Id-general-funs]{General @Id@-related functions}
447 %************************************************************************
450 unsafeGenId2Id :: GenId ty -> Id
451 unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i
453 isDataCon id = is_data (unsafeGenId2Id id)
455 is_data (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = True
456 is_data (Id _ _ (TupleConId _) _ _) = True
457 is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec
458 is_data other = False
461 isTupleCon id = is_tuple (unsafeGenId2Id id)
463 is_tuple (Id _ _ (TupleConId _) _ _) = True
464 is_tuple (Id _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
465 is_tuple other = False
468 isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _)
469 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
470 Just (unspec, ty_maybes)
471 isSpecId_maybe other_id
474 isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _)
476 isSpecPragmaId_maybe other_id
481 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a
482 nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be
483 defined at top level (returns @True@). This is used to decide whether
484 the @Id@ is a candidate free variable. NB: you are only {\em sure}
485 about something if it returns @True@!
488 toplevelishId :: Id -> Bool
489 idHasNoFreeTyVars :: Id -> Bool
491 toplevelishId (Id _ _ details _ _)
494 chk (DataConId _ _ _ _ _ _ _ _) = True
495 chk (TupleConId _) = True
496 chk (RecordSelectorId _) = True
497 chk (ImportedId _) = True
498 chk (PreludeId _) = True
499 chk (TopLevId _) = True -- NB: see notes
500 chk (SuperDictSelId _ _) = True
501 chk (MethodSelId _ _) = True
502 chk (DefaultMethodId _ _ _) = True
503 chk (DictFunId _ _ _ _) = True
504 chk (ConstMethodId _ _ _ _ _) = True
505 chk (SpecId unspec _ _) = toplevelishId unspec
506 -- depends what the unspecialised thing is
507 chk (WorkerId unwrkr) = toplevelishId unwrkr
508 chk (InstId _ _) = False -- these are local
509 chk (LocalId _ _) = False
510 chk (SysLocalId _ _) = False
511 chk (SpecPragmaId _ _ _) = False
513 idHasNoFreeTyVars (Id _ _ details _ info)
516 chk (DataConId _ _ _ _ _ _ _ _) = True
517 chk (TupleConId _) = True
518 chk (RecordSelectorId _) = True
519 chk (ImportedId _) = True
520 chk (PreludeId _) = True
521 chk (TopLevId _) = True
522 chk (SuperDictSelId _ _) = True
523 chk (MethodSelId _ _) = True
524 chk (DefaultMethodId _ _ _) = True
525 chk (DictFunId _ _ _ _) = True
526 chk (ConstMethodId _ _ _ _ _) = True
527 chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
528 chk (InstId _ no_free_tvs) = no_free_tvs
529 chk (SpecId _ _ no_free_tvs) = no_free_tvs
530 chk (LocalId _ no_free_tvs) = no_free_tvs
531 chk (SysLocalId _ no_free_tvs) = no_free_tvs
532 chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
536 isTopLevId (Id _ _ (TopLevId _) _ _) = True
537 isTopLevId other = False
539 isImportedId (Id _ _ (ImportedId _) _ _) = True
540 isImportedId other = False
542 isBottomingId (Id _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
544 isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
545 isSysLocalId other = False
547 isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True
548 isSpecPragmaId other = False
550 isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True
551 isMethodSelId _ = False
553 isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True
554 isDefaultMethodId other = False
556 isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _)
557 = Just (cls, clsop, err)
558 isDefaultMethodId_maybe other = Nothing
560 isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True
561 isDictFunId other = False
563 isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True
564 isConstMethodId other = False
566 isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _)
567 = Just (cls, ty, clsop)
568 isConstMethodId_maybe other = Nothing
570 isSuperDictSelId_maybe (Id _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
571 isSuperDictSelId_maybe other_id = Nothing
573 isWorkerId (Id _ _ (WorkerId _) _ _) = True
574 isWorkerId other = False
577 isWrapperId id = workerExists (getIdStrictness id)
583 pprIdInUnfolding :: IdSet -> Id -> Pretty
585 pprIdInUnfolding in_scopes v
590 if v `elementOfUniqSet` in_scopes then
591 pprUnique (getItsUnique v)
593 -- ubiquitous Ids with special syntax:
594 else if v == nilDataCon then
596 else if isTupleCon v then
597 ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
599 -- ones to think about:
602 (Id _ _ v_details _ _) = v
605 -- these ones must have been exported by their original module
606 ImportedId _ -> pp_full_name
607 PreludeId _ -> pp_full_name
609 -- these ones' exportedness checked later...
610 TopLevId _ -> pp_full_name
611 DataConId _ _ _ _ _ _ _ _ -> pp_full_name
613 RecordSelectorId lbl -> ppr sty lbl
615 -- class-ish things: class already recorded as "mentioned"
617 -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
619 -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
620 DefaultMethodId c o _
621 -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
623 -- instance-ish things: should we try to figure out
624 -- *exactly* which extra instances have to be exported? (ToDo)
626 -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
627 ConstMethodId c t o _ _
628 -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
630 -- specialisations and workers
631 SpecId unspec ty_maybes _
633 pp = pprIdInUnfolding in_scopes unspec
635 ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
636 ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
641 pp = pprIdInUnfolding in_scopes unwrkr
643 ppBeside (ppPStr SLIT("_WRKR_ ")) pp
645 -- anything else? we're nae interested
646 other_id -> panic "pprIdInUnfolding:mystery Id"
648 ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
652 (m_str, n_str) = getOrigName v
655 if isAvarop n_str || isAconop n_str then
656 ppBesides [ppLparen, ppPStr n_str, ppRparen]
660 if fromPreludeCore v then
663 ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
665 pp_class :: Class -> Pretty
666 pp_class_op :: ClassOp -> Pretty
667 pp_type :: Type -> Pretty
668 pp_ty_maybe :: Maybe Type -> Pretty
670 pp_class clas = ppr ppr_Unfolding clas
671 pp_class_op op = ppr ppr_Unfolding op
673 pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
675 pp_ty_maybe Nothing = ppPStr SLIT("_N_")
676 pp_ty_maybe (Just t) = pp_type t
680 @whatsMentionedInId@ ferrets out the types/classes/instances on which
681 this @Id@ depends. If this Id is to appear in an interface, then
682 those entities had Jolly Well be in scope. Someone else up the
683 call-tree decides that.
688 :: IdSet -- Ids known to be in scope
689 -> Id -- Id being processed
690 -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
692 whatsMentionedInId in_scopes v
697 = getMentionedTyConsAndClassesFromType v_ty
699 result0 id_bag = (id_bag, tycons, clss)
702 = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
703 tcs `unionBags` tycons,
707 if v `elementOfUniqSet` in_scopes then
708 result0 emptyBag -- v not added to "mentioned"
710 -- ones to think about:
713 (Id _ _ v_details _ _) = v
716 -- specialisations and workers
717 SpecId unspec ty_maybes _
719 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
721 result1 ids2 tcs2 cs2
725 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
727 result1 ids2 tcs2 cs2
729 anything_else -> result0 (unitBag v) -- v is added to "mentioned"
733 Tell them who my wrapper function is.
736 myWrapperMaybe :: Id -> Maybe Id
738 myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
739 myWrapperMaybe other_id = Nothing
744 unfoldingUnfriendlyId -- return True iff it is definitely a bad
745 :: Id -- idea to export an unfolding that
746 -> Bool -- mentions this Id. Reason: it cannot
747 -- possibly be seen in another module.
749 unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
752 unfoldingUnfriendlyId id
753 | not (externallyVisibleId id) -- that settles that...
756 unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _)
757 = class_thing wrapper
759 -- "class thing": If we're going to use this worker Id in
760 -- an interface, we *have* to be able to untangle the wrapper's
761 -- strictness when reading it back in. At the moment, this
762 -- is not always possible: in precisely those cases where
763 -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
765 class_thing (Id _ _ (SuperDictSelId _ _) _ _) = True
766 class_thing (Id _ _ (MethodSelId _ _) _ _) = True
767 class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True
768 class_thing other = False
770 unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _)
771 -- a SPEC of a DictFunId can end up w/ gratuitous
772 -- TyVar(Templates) in the i/face; only a problem
773 -- if -fshow-pragma-name-errs; but we can do without the pain.
774 -- A HACK in any case (WDP 94/05/02)
775 = naughty_DictFunId dfun
777 unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
778 = naughty_DictFunId dfun -- similar deal...
780 unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
782 naughty_DictFunId :: IdDetails -> Bool
783 -- True <=> has a TyVar(Template) in the "type" part of its "name"
785 naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
786 naughty_DictFunId (DictFunId _ ty _ _)
787 = not (isGroundTy ty)
791 @externallyVisibleId@: is it true that another module might be
792 able to ``see'' this Id?
794 We need the @toplevelishId@ check as well as @isExported@ for when we
795 compile instance declarations in the prelude. @DictFunIds@ are
796 ``exported'' if either their class or tycon is exported, but, in
797 compiling the prelude, the compiler may not recognise that as true.
800 externallyVisibleId :: Id -> Bool
802 externallyVisibleId id@(Id _ _ details _ _)
803 = if isLocallyDefined id then
804 toplevelishId id && isExported id && not (weird_datacon details)
806 not (weird_tuplecon details)
807 -- if visible here, it must be visible elsewhere, too.
809 -- If it's a DataCon, it's not enough to know it (meaning
810 -- its TyCon) is exported; we need to know that it might
811 -- be visible outside. Consider:
813 -- data Foo a = Mumble | BigFoo a WeirdLocalType
815 -- We can't tell the outside world *anything* about Foo, because
816 -- of WeirdLocalType; but we need to know this when asked if
817 -- "Mumble" is externally visible...
820 weird_datacon (DataConId _ _ _ _ _ _ _ tycon)
821 = maybeToBool (maybePurelyLocalTyCon tycon)
823 weird_datacon not_a_datacon_therefore_not_weird = False
825 weird_tuplecon (TupleConId arity)
826 = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
827 weird_tuplecon _ = False
831 idWantsToBeINLINEd :: Id -> Bool
833 idWantsToBeINLINEd (Id _ _ _ IWantToBeINLINEd _) = True
834 idWantsToBeINLINEd _ = False
837 For @unlocaliseId@: See the brief commentary in
838 \tr{simplStg/SimplStg.lhs}.
842 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
844 unlocaliseId mod (Id u ty info (TopLevId fn))
845 = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
847 unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
848 = --false?: ASSERT(no_ftvs)
850 full_name = unlocaliseShortName mod u sn
852 Just (Id u ty info (TopLevId full_name))
854 unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
855 = --false?: on PreludeGlaST: ASSERT(no_ftvs)
857 full_name = unlocaliseShortName mod u sn
859 Just (Id u ty info (TopLevId full_name))
861 unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
862 = case unlocalise_parent mod u unspec of
864 Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))
866 unlocaliseId mod (Id u ty info (WorkerId unwrkr))
867 = case unlocalise_parent mod u unwrkr of
869 Just xx -> Just (Id u ty info (WorkerId xx))
871 unlocaliseId mod (Id u ty info (InstId name no_ftvs))
872 = Just (Id u ty info (TopLevId full_name))
873 -- type might be wrong, but it hardly matters
874 -- at this stage (just before printing C) ToDo
876 name = getLocalName name
877 full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
879 unlocaliseId mod other_id = Nothing
882 -- we have to be Very Careful for workers/specs of
885 unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs))
886 = --false?: ASSERT(no_ftvs)
888 full_name = unlocaliseShortName mod uniq sn
890 Just (Id uniq ty info (TopLevId full_name))
892 unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
893 = --false?: ASSERT(no_ftvs)
895 full_name = unlocaliseShortName mod uniq sn
897 Just (Id uniq ty info (TopLevId full_name))
899 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
900 -- we're OK otherwise
904 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
905 `Top-levelish Ids'' cannot have any free type variables, so applying
906 the type-env cannot have any effect. (NB: checked in CoreLint?)
908 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
909 former ``should be'' the usual crunch point.
912 type TypeEnv = TyVarEnv Type
914 applyTypeEnvToId :: TypeEnv -> Id -> Id
916 applyTypeEnvToId type_env id@(Id _ ty _ _ _)
917 | idHasNoFreeTyVars id
920 = apply_to_Id ( \ ty ->
921 applyTypeEnvToTy type_env ty
926 apply_to_Id :: (Type -> Type)
930 apply_to_Id ty_fn (Id u ty details prag info)
934 Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
936 apply_to_details (SpecId unspec ty_maybes no_ftvs)
938 new_unspec = apply_to_Id ty_fn unspec
939 new_maybes = map apply_to_maybe ty_maybes
941 SpecId new_unspec new_maybes (no_free_tvs ty)
942 -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
944 apply_to_maybe Nothing = Nothing
945 apply_to_maybe (Just ty) = Just (ty_fn ty)
947 apply_to_details (WorkerId unwrkr)
949 new_unwrkr = apply_to_Id ty_fn unwrkr
953 apply_to_details other = other
956 Sadly, I don't think the one using the magic typechecker substitution
957 can be done with @apply_to_Id@. Here we go....
959 Strictness is very important here. We can't leave behind thunks
960 with pointers to the substitution: it {\em must} be single-threaded.
964 applySubstToId :: Subst -> Id -> (Subst, Id)
966 applySubstToId subst id@(Id u ty info details)
967 -- *cannot* have a "idHasNoFreeTyVars" get-out clause
968 -- because, in the typechecker, we are still
969 -- *concocting* the types.
970 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
971 case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
972 case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
973 (s4, Id u new_ty new_info new_details) }}}
975 apply_to_details subst _ (InstId inst no_ftvs)
976 = case (applySubstToInst subst inst) of { (s2, new_inst) ->
977 (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
979 apply_to_details subst new_ty (SpecId unspec ty_maybes _)
980 = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
981 case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
982 (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
983 -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
985 apply_to_maybe subst Nothing = (subst, Nothing)
986 apply_to_maybe subst (Just ty)
987 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
990 apply_to_details subst _ (WorkerId unwrkr)
991 = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
992 (s2, WorkerId new_unwrkr) }
994 apply_to_details subst _ other = (subst, other)
999 getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
1001 getIdNamePieces show_uniqs id
1002 = get (unsafeGenId2Id id)
1004 get (Id u _ details _ _)
1006 DataConId n _ _ _ _ _ _ _ ->
1007 case (getOrigName n) of { (mod, name) ->
1008 if fromPrelude mod then [name] else [mod, name] }
1010 TupleConId 0 -> [SLIT("()")]
1011 TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )]
1013 RecordSelectorId lbl -> panic "getIdNamePieces:RecordSelectorId"
1015 ImportedId n -> get_fullname_pieces n
1016 PreludeId n -> get_fullname_pieces n
1017 TopLevId n -> get_fullname_pieces n
1019 SuperDictSelId c sc ->
1020 case (getOrigName c) of { (c_mod, c_name) ->
1021 case (getOrigName sc) of { (sc_mod, sc_name) ->
1023 c_bits = if fromPreludeCore c
1025 else [c_mod, c_name]
1027 sc_bits= if fromPreludeCore sc
1029 else [sc_mod, sc_name]
1031 [SLIT("sdsel")] ++ c_bits ++ sc_bits }}
1033 MethodSelId clas op ->
1034 case (getOrigName clas) of { (c_mod, c_name) ->
1035 case (getClassOpString op) of { op_name ->
1036 if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name]
1039 DefaultMethodId clas op _ ->
1040 case (getOrigName clas) of { (c_mod, c_name) ->
1041 case (getClassOpString op) of { op_name ->
1042 if fromPreludeCore clas
1043 then [SLIT("defm"), op_name]
1044 else [SLIT("defm"), c_mod, c_name, op_name] }}
1046 DictFunId c ty _ _ ->
1047 case (getOrigName c) of { (c_mod, c_name) ->
1049 c_bits = if fromPreludeCore c
1051 else [c_mod, c_name]
1053 ty_bits = getTypeString ty
1055 [SLIT("dfun")] ++ c_bits ++ ty_bits }
1058 ConstMethodId c ty o _ _ ->
1059 case (getOrigName c) of { (c_mod, c_name) ->
1060 case (getTypeString ty) of { ty_bits ->
1061 case (getClassOpString o) of { o_name ->
1062 case (if fromPreludeCore c
1064 else [c_mod, c_name]) of { c_bits ->
1065 [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
1067 -- if the unspecialised equiv is "top-level",
1068 -- the name must be concocted from its name and the
1069 -- names of the types to which specialised...
1071 SpecId unspec ty_maybes _ ->
1072 get unspec ++ (if not (toplevelishId unspec)
1074 else concat (map typeMaybeString ty_maybes))
1077 get unwrkr ++ (if not (toplevelishId unwrkr)
1081 LocalId n _ -> let local = getLocalName n in
1082 if show_uniqs then [local, showUnique u] else [local]
1083 InstId n _ -> [getLocalName n, showUnique u]
1084 SysLocalId n _ -> [getLocalName n, showUnique u]
1085 SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
1087 get_fullname_pieces :: FullName -> [FAST_STRING]
1088 get_fullname_pieces n
1089 = BIND (getOrigName n) _TO_ (mod, name) ->
1096 %************************************************************************
1098 \subsection[Id-type-funs]{Type-related @Id@ functions}
1100 %************************************************************************
1103 idType :: GenId ty -> ty
1105 idType (Id _ ty _ _ _) = ty
1110 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1112 getMentionedTyConsAndClassesFromId id
1113 = getMentionedTyConsAndClassesFromType (idType id)
1118 idPrimRep i = typePrimRep (idType i)
1123 getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
1124 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
1125 getInstIdModule other = panic "Id:getInstIdModule"
1129 %************************************************************************
1131 \subsection[Id-overloading]{Functions related to overloading}
1133 %************************************************************************
1136 mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
1137 mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
1138 mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
1140 mkDictFunId u c ity full_ty from_here modname info
1141 = Id u full_ty (DictFunId c ity from_here modname) NoPragmaInfo info
1143 mkConstMethodId u c op ity full_ty from_here modname info
1144 = Id u full_ty (ConstMethodId c ity op from_here modname) NoPragmaInfo info
1146 mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
1148 mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo
1151 getConstMethodId clas op ty
1152 = -- constant-method info is hidden in the IdInfo of
1153 -- the class-op id (as mentioned up above).
1155 sel_id = getMethodSelId clas op
1157 case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1159 Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
1160 ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1161 ppr PprDebug sel_id],
1162 ppStr "(This can arise if an interface pragma refers to an instance",
1163 ppStr "but there is no imported interface which *defines* that instance.",
1164 ppStr "The info above, however ugly, should indicate what else you need to import."
1169 %************************************************************************
1171 \subsection[local-funs]{@LocalId@-related functions}
1173 %************************************************************************
1176 mkImported u n ty info = Id u ty (ImportedId n) NoPragmaInfo info
1177 mkPreludeId u n ty info = Id u ty (PreludeId n) NoPragmaInfo info
1180 updateIdType :: Id -> Type -> Id
1181 updateIdType (Id u _ info details) ty = Id u ty info details
1186 type MyTy a b = GenType (GenTyVar a) b
1187 type MyId a b = GenId (MyTy a b)
1189 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1191 -- SysLocal: for an Id being created by the compiler out of thin air...
1192 -- UserLocal: an Id with a name the user might recognize...
1193 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1195 mkSysLocal str uniq ty loc
1196 = Id uniq ty (SysLocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1198 mkUserLocal str uniq ty loc
1199 = Id uniq ty (LocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1201 -- mkUserId builds a local or top-level Id, depending on the name given
1202 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1203 mkUserId (Short uniq short) ty pragma_info
1204 = Id uniq ty (LocalId short (no_free_tvs ty)) pragma_info noIdInfo
1205 mkUserId (ValName uniq full) ty pragma_info
1207 (if isLocallyDefined full then TopLevId full else ImportedId full)
1208 pragma_info noIdInfo
1215 -- for a SpecPragmaId being created by the compiler out of thin air...
1216 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1217 mkSpecPragmaId str uniq ty specid loc
1218 = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
1221 mkSpecId u unspec ty_maybes ty info
1222 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1223 Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1225 -- Specialised version of constructor: only used in STG and code generation
1226 -- Note: The specialsied Id has the same unique as the unspeced Id
1228 mkSameSpecCon ty_maybes unspec@(Id u ty info details)
1229 = ASSERT(isDataCon unspec)
1230 ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1231 Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1233 new_ty = specialiseTy ty ty_maybes 0
1235 localiseId :: Id -> Id
1236 localiseId id@(Id u ty info details)
1237 = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
1239 name = getOccurrenceName id
1243 mkIdWithNewUniq :: Id -> Unique -> Id
1245 mkIdWithNewUniq (Id _ ty details prag info) uniq
1246 = Id uniq ty details prag info
1249 Make some local @Ids@ for a template @CoreExpr@. These have bogus
1250 @Uniques@, but that's OK because the templates are supposed to be
1251 instantiated before use.
1253 mkTemplateLocals :: [Type] -> [Id]
1254 mkTemplateLocals tys
1255 = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1256 (getBuiltinUniques (length tys))
1261 getIdInfo :: GenId ty -> IdInfo
1262 getPragmaInfo :: GenId ty -> PragmaInfo
1264 getIdInfo (Id _ _ _ _ info) = info
1265 getPragmaInfo (Id _ _ _ info _) = info
1268 replaceIdInfo :: Id -> IdInfo -> Id
1270 replaceIdInfo (Id u ty _ details) info = Id u ty info details
1272 selectIdInfoForSpecId :: Id -> IdInfo
1273 selectIdInfoForSpecId unspec
1274 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1275 noIdInfo `addInfo_UF` getIdUnfolding unspec
1279 %************************************************************************
1281 \subsection[Id-arities]{Arity-related functions}
1283 %************************************************************************
1285 For locally-defined Ids, the code generator maintains its own notion
1286 of their arities; so it should not be asking... (but other things
1287 besides the code-generator need arity info!)
1290 getIdArity :: Id -> ArityInfo
1291 getIdArity (Id _ _ _ _ id_info) = getInfo id_info
1293 dataConArity :: DataCon -> Int
1294 dataConArity id@(Id _ _ _ _ id_info)
1295 = ASSERT(isDataCon id)
1296 case (arityMaybe (getInfo id_info)) of
1297 Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1300 addIdArity :: Id -> Int -> Id
1301 addIdArity (Id u ty details pinfo info) arity
1302 = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
1305 %************************************************************************
1307 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1309 %************************************************************************
1312 mkDataCon :: Unique{-DataConKey-}
1314 -> [StrictnessMark] -> [FieldLabel]
1315 -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1318 -- can get the tag and all the pieces of the type from the Type
1320 mkDataCon k n stricts fields tvs ctxt args_tys tycon
1321 = ASSERT(length stricts == length args_tys)
1324 -- NB: data_con self-recursion; should be OK as tags are not
1325 -- looked at until late in the game.
1329 (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon)
1333 data_con_tag = position_within fIRST_TAG data_con_family
1335 data_con_family = tyConDataCons tycon
1337 position_within :: Int -> [Id] -> Int
1339 position_within acc (c:cs)
1340 = if c == data_con then acc else position_within (acc+1) cs
1342 position_within acc []
1343 = panic "mkDataCon: con not found in family"
1347 = mkSigmaTy tvs ctxt
1348 (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1350 datacon_info = noIdInfo `addInfo_UF` unfolding
1351 `addInfo` mkArityInfo arity
1352 --ToDo: `addInfo` specenv
1354 arity = length args_tys
1361 -- else -- do some business...
1363 (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1364 tyvar_tys = mkTyVarTys tyvars
1366 BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1368 mkUnfolding EssentialUnfolding -- for data constructors
1369 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1372 mk_uf_bits tvs ctxt arg_tys tycon
1374 (inst_env, tyvars, tyvar_tys)
1375 = instantiateTyVarTemplates tvs
1376 (map getItsUnique tvs)
1378 -- the "context" and "arg_tys" have TyVarTemplates in them, so
1379 -- we instantiate those types to have the right TyVars in them
1381 BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1382 _TO_ inst_dict_tys ->
1383 BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys ->
1385 -- We can only have **ONE** call to mkTemplateLocals here;
1386 -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1387 -- (Mega-Sigh) [ToDo]
1388 BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
1390 BIND (splitAt (length ctxt) all_vars) _TO_ (dict_vars, vars) ->
1392 (tyvars, dict_vars, vars)
1395 -- these are really dubious Types, but they are only to make the
1396 -- binders for the lambdas for tossed-away dicts.
1397 ctxt_ty (clas, ty) = mkDictTy clas ty
1402 mkTupleCon :: Arity -> Id
1405 = Id unique ty (TupleConId arity) NoPragmaInfo tuplecon_info
1407 unique = mkTupleDataConUnique arity
1408 ty = mkSigmaTy tyvars []
1409 (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1410 tycon = mkTupleTyCon arity
1411 tyvars = take arity alphaTyVars
1412 tyvar_tys = mkTyVarTys tyvars
1415 = noIdInfo `addInfo_UF` unfolding
1416 `addInfo` mkArityInfo arity
1417 --LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1424 -- else -- do some business...
1426 (tyvars, dict_vars, vars) = mk_uf_bits arity
1427 tyvar_tys = mkTyVarTys tyvars
1429 BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1432 EssentialUnfolding -- data constructors
1433 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1437 = BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
1441 tyvar_tmpls = take arity alphaTyVars
1442 (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
1446 fIRST_TAG = 1 -- Tags allocated from here for real constructors
1450 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1451 dataConTag (Id _ _ (DataConId _ tag _ _ _ _ _ _) _ _) = tag
1452 dataConTag (Id _ _ (TupleConId _) _ _) = fIRST_TAG
1453 dataConTag (Id _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
1455 dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
1456 dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon
1457 dataConTyCon (Id _ _ (TupleConId a) _ _) = mkTupleTyCon a
1459 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1460 -- will panic if not a DataCon
1462 dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1463 = (tyvars, theta_ty, arg_tys, tycon)
1465 dataConSig (Id _ _ (TupleConId arity) _ _)
1466 = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1468 tyvars = take arity alphaTyVars
1469 tyvar_tys = mkTyVarTys tyvars
1471 dataConFieldLabels :: DataCon -> [FieldLabel]
1472 dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields
1476 mkRecordSelectorId field_label selector_ty
1477 = Id (getItsUnique name)
1479 (RecordSelectorId field_label)
1483 name = fieldLabelName field_label
1485 recordSelectorFieldLabel :: Id -> FieldLabel
1486 recordSelectorFieldLabel (Id _ _ (RecordSelectorId lbl) _ _) = lbl
1490 dataConTyCon (Id _ _ _ (SpecId unspec tys _))
1491 = mkSpecTyCon (dataConTyCon unspec) tys
1493 dataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
1494 = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
1496 (tyvars, theta_ty, arg_tys, tycon) = dataConSig unspec
1498 ty_env = tyvars `zip` ty_maybes
1500 spec_tyvars = foldr nothing_tyvars [] ty_env
1501 nothing_tyvars (tyvar, Nothing) l = tyvar : l
1502 nothing_tyvars (tyvar, Just ty) l = l
1504 spec_env = foldr just_env [] ty_env
1505 just_env (tyvar, Nothing) l = l
1506 just_env (tyvar, Just ty) l = (tyvar, ty) : l
1507 spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
1509 spec_theta_ty = if null theta_ty then []
1510 else panic "dataConSig:ThetaTy:SpecDataCon"
1511 spec_tycon = mkSpecTyCon tycon ty_maybes
1516 @getInstantiatedDataConSig@ takes a constructor and some types to which
1517 it is applied; it returns its signature instantiated to these types.
1520 getInstantiatedDataConSig ::
1521 DataCon -- The data constructor
1522 -- Not a specialised data constructor
1523 -> [TauType] -- Types to which applied
1524 -- Must be fully applied i.e. contain all types of tycon
1525 -> ([TauType], -- Types of dict args
1526 [TauType], -- Types of regular args
1527 TauType -- Type of result
1530 getInstantiatedDataConSig data_con inst_tys
1531 = ASSERT(isDataCon data_con)
1533 (tvs, theta, arg_tys, tycon) = dataConSig data_con
1535 inst_env = ASSERT(length tvs == length inst_tys)
1538 theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ]
1539 cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ]
1540 result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys)
1542 -- Are the first/third results ever used?
1543 (theta_tys, cmpnt_tys, result_ty)
1546 Data type declarations are of the form:
1548 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1550 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1551 @C1 x y z@, we want a function binding:
1553 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1555 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1556 2nd-order polymorphic lambda calculus with explicit types.
1558 %************************************************************************
1560 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1562 %************************************************************************
1564 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1565 and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
1566 @TyVars@ don't really have to be new, because we are only producing a
1569 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1572 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1573 EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the
1574 example above: a, b, and x, y, z], which is enough (in the important
1575 \tr{DsExpr} case). (The middle set of @Ids@ is binders for any
1576 dictionaries, in the even of an overloaded data-constructor---none at
1580 getIdUnfolding :: Id -> UnfoldingDetails
1582 getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info
1585 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1586 addIdUnfolding id@(Id u ty info details) unfold_details
1588 case (isLocallyDefined id, unfold_details) of
1589 (_, NoUnfoldingDetails) -> True
1590 (True, IWantToBeINLINEd _) -> True
1591 (False, IWantToBeINLINEd _) -> False -- v bad
1595 Id u ty (info `addInfo_UF` unfold_details) details
1599 In generating selector functions (take a dictionary, give back one
1600 component...), we need to what out for the nothing-to-select cases (in
1601 which case the ``selector'' is just an identity function):
1603 class Eq a => Foo a { } # the superdict selector for "Eq"
1605 class Foo a { op :: Complex b => c -> b -> a }
1606 # the method selector for "op";
1607 # note local polymorphism...
1610 %************************************************************************
1612 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1614 %************************************************************************
1617 getIdDemandInfo :: Id -> DemandInfo
1618 getIdDemandInfo (Id _ _ _ _ info) = getInfo info
1620 addIdDemandInfo :: Id -> DemandInfo -> Id
1621 addIdDemandInfo (Id u ty details prags info) demand_info
1622 = Id u ty details prags (info `addInfo` demand_info)
1626 getIdUpdateInfo :: Id -> UpdateInfo
1627 getIdUpdateInfo (Id _ _ _ _ info) = getInfo info
1629 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1630 addIdUpdateInfo (Id u ty details prags info) upd_info
1631 = Id u ty details prags (info `addInfo` upd_info)
1636 getIdArgUsageInfo :: Id -> ArgUsageInfo
1637 getIdArgUsageInfo (Id u ty info details) = getInfo info
1639 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1640 addIdArgUsageInfo (Id u ty info details) au_info
1641 = Id u ty (info `addInfo` au_info) details
1647 getIdFBTypeInfo :: Id -> FBTypeInfo
1648 getIdFBTypeInfo (Id u ty info details) = getInfo info
1650 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1651 addIdFBTypeInfo (Id u ty info details) upd_info
1652 = Id u ty (info `addInfo` upd_info) details
1658 getIdSpecialisation :: Id -> SpecEnv
1659 getIdSpecialisation (Id _ _ _ _ info) = getInfo info
1661 addIdSpecialisation :: Id -> SpecEnv -> Id
1662 addIdSpecialisation (Id u ty details prags info) spec_info
1663 = Id u ty details prags (info `addInfo` spec_info)
1667 Strictness: we snaffle the info out of the IdInfo.
1670 getIdStrictness :: Id -> StrictnessInfo
1672 getIdStrictness (Id _ _ _ _ info) = getInfo info
1674 addIdStrictness :: Id -> StrictnessInfo -> Id
1676 addIdStrictness (Id u ty details prags info) strict_info
1677 = Id u ty details prags (info `addInfo` strict_info)
1680 %************************************************************************
1682 \subsection[Id-comparison]{Comparison functions for @Id@s}
1684 %************************************************************************
1686 Comparison: equality and ordering---this stuff gets {\em hammered}.
1689 cmpId (Id u1 _ _ _ _) (Id u2 _ _ _ _) = cmp u1 u2
1690 -- short and very sweet
1694 instance Ord3 (GenId ty) where
1697 instance Eq (GenId ty) where
1698 a == b = case cmpId a b of { EQ_ -> True; _ -> False }
1699 a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
1701 instance Ord (GenId ty) where
1702 a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
1703 a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
1704 a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
1705 a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
1706 _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1709 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1710 account when comparing two data constructors. We need to do this
1711 because a specialised data constructor has the same Unique as its
1712 unspecialised counterpart.
1715 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1717 cmpId_withSpecDataCon id1 id2
1718 | eq_ids && isDataCon id1 && isDataCon id2
1719 = cmpEqDataCon id1 id2
1724 cmp_ids = cmpId id1 id2
1725 eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
1727 cmpEqDataCon (Id _ _ (SpecId _ mtys1 _) _ _) (Id _ _ (SpecId _ mtys2 _) _ _)
1728 = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1730 cmpEqDataCon _ (Id _ _ (SpecId _ _ _) _ _) = LT_
1731 cmpEqDataCon (Id _ _ (SpecId _ _ _) _ _) _ = GT_
1732 cmpEqDataCon _ _ = EQ_
1735 %************************************************************************
1737 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1739 %************************************************************************
1742 instance Outputable ty => Outputable (GenId ty) where
1743 ppr sty id = pprId sty id
1745 -- and a SPECIALIZEd one:
1746 instance Outputable {-Id, i.e.:-}(GenId Type) where
1747 ppr sty id = pprId sty id
1749 showId :: PprStyle -> Id -> String
1750 showId sty id = ppShow 80 (pprId sty id)
1753 -- for DictFuns (instances) and const methods (instance code bits we
1754 -- can call directly): exported (a) if *either* the class or
1755 -- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
1756 -- class and tycon are from PreludeCore [non-std, but convenient]
1757 -- *and* the thing was defined in this module.
1759 instance_export_flag :: Class -> Type -> Bool -> ExportFlag
1761 instance_export_flag clas inst_ty from_here
1762 = panic "Id:instance_export_flag"
1764 = if instanceIsExported clas inst_ty from_here
1770 Do we consider an ``instance type'' (as on a @DictFunId@) to be ``from
1771 PreludeCore''? True if the outermost TyCon is fromPreludeCore.
1773 is_prelude_core_ty :: Type -> Bool
1775 is_prelude_core_ty inst_ty
1776 = panic "Id.is_prelude_core_ty"
1778 = case maybeAppDataTyCon inst_ty of
1779 Just (tycon,_,_) -> fromPreludeCore tycon
1780 Nothing -> panic "Id: is_prelude_core_ty"
1784 Default printing code (not used for interfaces):
1786 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1790 pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
1794 pieces_to_print -- maybe use Unique only
1795 = if isSysLocalId id then tail pieces else pieces
1797 ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
1801 PprForAsm _ _ -> for_code
1802 PprInterface -> ppPStr occur_name
1803 PprForUser -> ppPStr occur_name
1804 PprUnfolding -> qualified_name pieces
1805 PprDebug -> qualified_name pieces
1806 PprShowAll -> ppBesides [qualified_name pieces,
1809 ppr other_sty (idType id),
1810 ppIdInfo other_sty (unsafeGenId2Id id) True
1811 (\x->x) nullIdEnv (getIdInfo id),
1812 ppPStr SLIT("-}") ])]
1814 occur_name = getOccurrenceName id _APPEND_
1815 ( _PK_ (if not (isSysLocalId id)
1817 else "." ++ (_UNPK_ (showUnique (getItsUnique id)))))
1819 qualified_name pieces
1820 = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
1822 pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add
1823 pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = ppNil
1824 pp_uniq (Id _ _ (TupleConId _) _ _) = ppNil
1825 pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere
1826 pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil
1827 pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil
1828 pp_uniq (Id _ _ (InstId _ _) _ _) = ppNil
1829 pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getItsUnique other_id), ppPStr SLIT("-}")]
1831 -- print PprDebug Ids with # afterwards if they are of primitive type.
1832 pp_ubxd pretty = pretty
1834 {- LATER: applying isPrimType restricts type
1835 pp_ubxd pretty = if isPrimType (idType id)
1836 then ppBeside pretty (ppChar '#')
1843 instance NamedThing (GenId ty) where
1844 getExportFlag (Id _ _ details _ _)
1847 get (DataConId _ _ _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
1848 get (TupleConId _) = NotExported
1849 get (RecordSelectorId l) = getExportFlag l
1850 get (ImportedId n) = getExportFlag n
1851 get (PreludeId n) = getExportFlag n
1852 get (TopLevId n) = getExportFlag n
1853 get (SuperDictSelId c _) = getExportFlag c
1854 get (MethodSelId c _) = getExportFlag c
1855 get (DefaultMethodId c _ _) = getExportFlag c
1856 get (DictFunId c ty from_here _) = instance_export_flag c ty from_here
1857 get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here
1858 get (SpecId unspec _ _) = getExportFlag unspec
1859 get (WorkerId unwrkr) = getExportFlag unwrkr
1860 get (InstId _ _) = NotExported
1861 get (LocalId _ _) = NotExported
1862 get (SysLocalId _ _) = NotExported
1863 get (SpecPragmaId _ _ _) = NotExported
1865 isLocallyDefined this_id@(Id _ _ details _ _)
1868 get (DataConId _ _ _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
1869 get (TupleConId _) = False
1870 get (ImportedId _) = False
1871 get (PreludeId _) = False
1872 get (RecordSelectorId l) = isLocallyDefined l
1873 get (TopLevId n) = isLocallyDefined n
1874 get (SuperDictSelId c _) = isLocallyDefined c
1875 get (MethodSelId c _) = isLocallyDefined c
1876 get (DefaultMethodId c _ _) = isLocallyDefined c
1877 get (DictFunId c tyc from_here _) = from_here
1878 -- For DictFunId and ConstMethodId things, you really have to
1879 -- know whether it came from an imported instance or one
1880 -- really here; no matter where the tycon and class came from.
1882 get (ConstMethodId c tyc _ from_here _) = from_here
1883 get (SpecId unspec _ _) = isLocallyDefined unspec
1884 get (WorkerId unwrkr) = isLocallyDefined unwrkr
1885 get (InstId _ _) = True
1886 get (LocalId _ _) = True
1887 get (SysLocalId _ _) = True
1888 get (SpecPragmaId _ _ _) = True
1890 getOrigName this_id@(Id u _ details _ _)
1893 get (DataConId n _ _ _ _ _ _ _) = getOrigName n
1894 get (TupleConId 0) = (pRELUDE_BUILTIN, SLIT("()"))
1895 get (TupleConId a) = (pRELUDE_BUILTIN, _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" ))
1896 get (RecordSelectorId l)= getOrigName l
1897 get (ImportedId n) = getOrigName n
1898 get (PreludeId n) = getOrigName n
1899 get (TopLevId n) = getOrigName n
1901 get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ???
1902 (mod, _) -> (mod, getClassOpString op)
1905 get (SpecId unspec ty_maybes _)
1906 = BIND getOrigName unspec _TO_ (mod, unspec_nm) ->
1907 BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
1910 (if not (toplevelishId unspec)
1916 get (WorkerId unwrkr)
1917 = BIND getOrigName unwrkr _TO_ (mod, unwrkr_nm) ->
1920 (if not (toplevelishId unwrkr)
1927 get (InstId n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
1929 get (LocalId n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
1931 get (SysLocalId n _) = (panic "NamedThing.Id.getOrigName (SysLocal)",
1933 get (SpecPragmaId n _ _)= (panic "NamedThing.Id.getOrigName (SpecPragmaId)",
1937 -- the remaining internally-generated flavours of
1938 -- Ids really do not have meaningful "original name" stuff,
1939 -- but we need to make up something (usually for debugging output)
1941 = BIND (getIdNamePieces True this_id) _TO_ (piece1:pieces) ->
1942 BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
1943 (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
1946 getOccurrenceName this_id@(Id _ _ details _ _)
1949 get (DataConId n _ _ _ _ _ _ _) = getOccurrenceName n
1950 get (TupleConId 0) = SLIT("()")
1951 get (TupleConId a) = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
1952 get (RecordSelectorId l)= getOccurrenceName l
1953 get (ImportedId n) = getOccurrenceName n
1954 get (PreludeId n) = getOccurrenceName n
1955 get (TopLevId n) = getOccurrenceName n
1956 get (MethodSelId _ op) = getClassOpString op
1957 get _ = snd (getOrigName this_id)
1959 getInformingModules id = panic "getInformingModule:Id"
1961 getSrcLoc (Id _ _ details _ id_info)
1964 get (DataConId n _ _ _ _ _ _ _) = getSrcLoc n
1965 get (TupleConId _) = mkBuiltinSrcLoc
1966 get (RecordSelectorId l)= getSrcLoc l
1967 get (ImportedId n) = getSrcLoc n
1968 get (PreludeId n) = getSrcLoc n
1969 get (TopLevId n) = getSrcLoc n
1970 get (SuperDictSelId c _)= getSrcLoc c
1971 get (MethodSelId c _) = getSrcLoc c
1972 get (SpecId unspec _ _) = getSrcLoc unspec
1973 get (WorkerId unwrkr) = getSrcLoc unwrkr
1974 get (InstId n _) = getSrcLoc n
1975 get (LocalId n _) = getSrcLoc n
1976 get (SysLocalId n _) = getSrcLoc n
1977 get (SpecPragmaId n _ _)= getSrcLoc n
1978 -- well, try the IdInfo
1979 get something_else = getSrcLocIdInfo id_info
1981 getItsUnique (Id u _ _ _ _) = u
1983 fromPreludeCore (Id _ _ details _ _)
1986 get (DataConId _ _ _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
1987 get (TupleConId _) = True
1988 get (RecordSelectorId l) = fromPreludeCore l
1989 get (ImportedId n) = fromPreludeCore n
1990 get (PreludeId n) = fromPreludeCore n
1991 get (TopLevId n) = fromPreludeCore n
1992 get (SuperDictSelId c _) = fromPreludeCore c
1993 get (MethodSelId c _) = fromPreludeCore c
1994 get (DefaultMethodId c _ _) = fromPreludeCore c
1995 get (DictFunId c t _ _) = fromPreludeCore c && is_prelude_core_ty t
1996 get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t
1997 get (SpecId unspec _ _) = fromPreludeCore unspec
1998 get (WorkerId unwrkr) = fromPreludeCore unwrkr
1999 get (InstId _ _) = False
2000 get (LocalId _ _) = False
2001 get (SysLocalId _ _) = False
2002 get (SpecPragmaId _ _ _) = False
2005 Reason for @getItsUnique@: The code generator doesn't carry a
2006 @UniqueSupply@, so it wants to use the @Uniques@ out of local @Ids@
2009 %************************************************************************
2011 \subsection{@IdEnv@s and @IdSet@s}
2013 %************************************************************************
2016 type IdEnv elt = UniqFM elt
2018 nullIdEnv :: IdEnv a
2020 mkIdEnv :: [(GenId ty, a)] -> IdEnv a
2021 unitIdEnv :: GenId ty -> a -> IdEnv a
2022 addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
2023 growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
2024 growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
2026 delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
2027 delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
2028 combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
2029 mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
2030 modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
2031 rngIdEnv :: IdEnv a -> [a]
2033 isNullIdEnv :: IdEnv a -> Bool
2034 lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
2035 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
2039 addOneToIdEnv = addToUFM
2040 combineIdEnvs = plusUFM_C
2041 delManyFromIdEnv = delListFromUFM
2042 delOneFromIdEnv = delFromUFM
2044 lookupIdEnv = lookupUFM
2047 nullIdEnv = emptyUFM
2051 growIdEnvList env pairs = plusUFM env (listToUFM pairs)
2052 isNullIdEnv env = sizeUFM env == 0
2053 lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
2055 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
2056 -- modify function, and put it back.
2058 modifyIdEnv env mangle_fn key
2059 = case (lookupIdEnv env key) of
2061 Just xx -> addOneToIdEnv env key (mangle_fn xx)
2065 type GenIdSet ty = UniqSet (GenId ty)
2066 type IdSet = UniqSet (GenId Type)
2068 emptyIdSet :: GenIdSet ty
2069 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
2070 unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
2071 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
2072 idSetToList :: GenIdSet ty -> [GenId ty]
2073 unitIdSet :: GenId ty -> GenIdSet ty
2074 addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
2075 elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
2076 minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
2077 isEmptyIdSet :: GenIdSet ty -> Bool
2078 mkIdSet :: [GenId ty] -> GenIdSet ty
2080 emptyIdSet = emptyUniqSet
2081 unitIdSet = unitUniqSet
2082 addOneToIdSet = addOneToUniqSet
2083 intersectIdSets = intersectUniqSets
2084 unionIdSets = unionUniqSets
2085 unionManyIdSets = unionManyUniqSets
2086 idSetToList = uniqSetToList
2087 elementOfIdSet = elementOfUniqSet
2088 minusIdSet = minusUniqSet
2089 isEmptyIdSet = isEmptyUniqSet