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
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,
109 import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
110 import Outputable ( isAvarop, isAconop, getLocalName,
111 isLocallyDefined, isPreludeDefined,
112 getOrigName, getOccName,
113 isExported, ExportFlag(..)
115 import PragmaInfo ( PragmaInfo(..) )
116 import PrelMods ( pRELUDE_BUILTIN )
117 import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
122 import SrcLoc ( mkBuiltinSrcLoc )
123 import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
124 import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
125 applyTyCon, isPrimType, instantiateTy,
126 tyVarsOfType, applyTypeEnvToTy, typePrimRep,
127 GenType, ThetaType(..), TauType(..), Type(..)
129 import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
131 import UniqSet -- practically all of it
132 import UniqSupply ( getBuiltinUniques )
133 import Unique ( mkTupleDataConUnique, pprUnique, showUnique,
134 Unique{-instance Ord3-}
136 import Util ( mapAccumL, nOfThem,
137 panic, panic#, pprPanic, assertPanic
141 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
144 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
145 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
146 strictness). The essential info about different kinds of @Ids@ is
149 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
153 Unique -- Key for fast comparison
154 ty -- Id's type; used all the time;
155 IdDetails -- Stuff about individual kinds of Ids.
156 PragmaInfo -- Properties of this Id requested by programmer
157 -- eg specialise-me, inline-me
158 IdInfo -- Properties of this Id deduced by compiler
162 data StrictnessMark = MarkedStrict | NotMarkedStrict
166 ---------------- Local values
168 = LocalId Name -- Local name; mentioned by the user
169 Bool -- True <=> no free type vars
171 | SysLocalId Name -- Local name; made up by the compiler
172 Bool -- as for LocalId
174 | SpecPragmaId Name -- Local name; introduced by the compiler
175 (Maybe Id) -- for explicit specid in pragma
176 Bool -- as for LocalId
178 ---------------- Global values
180 | ImportedId Name -- Global name (Imported or Implicit); Id imported from an interface
182 | PreludeId Name -- Global name (Builtin); Builtin prelude Ids
184 | TopLevId Name -- Global name (LocalDef); Top-level in the orig source pgm
185 -- (not moved there by transformations).
187 -- a TopLevId's type may contain free type variables, if
188 -- the monomorphism restriction applies.
190 ---------------- Data constructors
194 [StrictnessMark] -- Strict args; length = arity
195 [FieldLabel] -- Field labels for this constructor
197 [TyVar] [(Class,Type)] [Type] TyCon
199 -- forall tyvars . theta_ty =>
200 -- unitype_1 -> ... -> unitype_n -> tycon tyvars
205 | RecordSelId FieldLabel
207 ---------------- Things to do with overloading
209 | SuperDictSelId -- Selector for superclass dictionary
210 Class -- The class (input dict)
211 Class -- The superclass (result dict)
213 | MethodSelId Class -- An overloaded class operation, with
214 -- a fully polymorphic type. Its code
215 -- just selects a method from the
216 -- dictionary. The class.
217 ClassOp -- The operation
219 -- NB: The IdInfo for a MethodSelId has all the info about its
220 -- related "constant method Ids", which are just
221 -- specialisations of this general one.
223 | DefaultMethodId -- Default method for a particular class op
224 Class -- same class, <blah-blah> info as MethodSelId
225 ClassOp -- (surprise, surprise)
226 Bool -- True <=> I *know* this default method Id
227 -- is a generated one that just says
228 -- `error "No default method for <op>"'.
231 | DictFunId Class -- A DictFun is uniquely identified
232 Type -- by its class and type; this type has free type vars,
233 -- whose identity is irrelevant. Eg Class = Eq
235 -- The "a" is irrelevant. As it is too painful to
236 -- actually do comparisons that way, we kindly supply
237 -- a Unique for that purpose.
238 Bool -- True <=> from an instance decl in this mod
239 (Maybe Module) -- module where instance came from; Nothing => Prelude
242 | ConstMethodId -- A method which depends only on the type of the
243 -- instance, and not on any further dictionaries etc.
244 Class -- Uniquely identified by:
245 Type -- (class, type, classop) triple
247 Bool -- True => from an instance decl in this mod
248 (Maybe Module) -- module where instance came from; Nothing => Prelude
250 | InstId Name -- An instance of a dictionary, class operation,
251 -- or overloaded value (Local name)
252 Bool -- as for LocalId
254 | SpecId -- A specialisation of another Id
255 Id -- Id of which this is a specialisation
256 [Maybe Type] -- Types at which it is specialised;
257 -- A "Nothing" says this type ain't relevant.
258 Bool -- True <=> no free type vars; it's not enough
259 -- to know about the unspec version, because
260 -- we may specialise to a type w/ free tyvars
261 -- (i.e., in one of the "Maybe Type" dudes).
263 | WorkerId -- A "worker" for some other Id
264 Id -- Id for which this is a worker
274 DictFunIds are generated from instance decls.
279 instance Foo a => Foo [a] where
282 generates the dict fun id decl
284 dfun.Foo.[*] = \d -> ...
286 The dfun id is uniquely named by the (class, type) pair. Notice, it
287 isn't a (class,tycon) pair any more, because we may get manually or
288 automatically generated specialisations of the instance decl:
290 instance Foo [Int] where
297 The type variables in the name are irrelevant; we print them as stars.
300 Constant method ids are generated from instance decls where
301 there is no context; that is, no dictionaries are needed to
302 construct the method. Example
304 instance Foo Int where
307 Then we get a constant method
312 It is possible, albeit unusual, to have a constant method
313 for an instance decl which has type vars:
315 instance Foo [a] where
319 We get the constant method
323 So a constant method is identified by a class/op/type triple.
324 The type variables in the type are irrelevant.
327 For Ids whose names must be known/deducible in other modules, we have
328 to conjure up their worker's names (and their worker's worker's
329 names... etc) in a known systematic way.
332 %************************************************************************
334 \subsection[Id-documentation]{Documentation}
336 %************************************************************************
340 The @Id@ datatype describes {\em values}. The basic things we want to
341 know: (1)~a value's {\em type} (@idType@ is a very common
342 operation in the compiler); and (2)~what ``flavour'' of value it might
343 be---for example, it can be terribly useful to know that a value is a
347 %----------------------------------------------------------------------
348 \item[@DataConId@:] For the data constructors declared by a @data@
349 declaration. Their type is kept in {\em two} forms---as a regular
350 @Type@ (in the usual place), and also in its constituent pieces (in
351 the ``details''). We are frequently interested in those pieces.
353 %----------------------------------------------------------------------
354 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
355 the infinite family of tuples.
357 %----------------------------------------------------------------------
358 \item[@ImportedId@:] These are values defined outside this module.
359 {\em Everything} we want to know about them must be stored here (or in
362 %----------------------------------------------------------------------
363 \item[@PreludeId@:] ToDo
365 %----------------------------------------------------------------------
366 \item[@TopLevId@:] These are values defined at the top-level in this
367 module; i.e., those which {\em might} be exported (hence, a
368 @Name@). It does {\em not} include those which are moved to the
369 top-level through program transformations.
371 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
372 Theoretically, they could be floated inwards, but there's no known
373 advantage in doing so. This way, we can keep them with the same
374 @Unique@ throughout (no cloning), and, in general, we don't have to be
375 so paranoid about them.
377 In particular, we had the following problem generating an interface:
378 We have to ``stitch together'' info (1)~from the typechecker-produced
379 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
380 what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change}
381 between (1) and (2), you're sunk!
383 %----------------------------------------------------------------------
384 \item[@MethodSelId@:] A selector from a dictionary; it may select either
385 a method or a dictionary for one of the class's superclasses.
387 %----------------------------------------------------------------------
390 @mkDictFunId [a,b..] theta C T@ is the function derived from the
393 instance theta => C (T a b ..) where
396 It builds function @Id@ which maps dictionaries for theta,
397 to a dictionary for C (T a b ..).
399 *Note* that with the ``Mark Jones optimisation'', the theta may
400 include dictionaries for the immediate superclasses of C at the type
403 %----------------------------------------------------------------------
406 %----------------------------------------------------------------------
409 %----------------------------------------------------------------------
412 %----------------------------------------------------------------------
413 \item[@LocalId@:] A purely-local value, e.g., a function argument,
414 something defined in a @where@ clauses, ... --- but which appears in
415 the original program text.
417 %----------------------------------------------------------------------
418 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
419 the original program text; these are introduced by the compiler in
422 %----------------------------------------------------------------------
423 \item[@SpecPragmaId@:] Introduced by the compiler to record
424 Specialisation pragmas. It is dead code which MUST NOT be removed
425 before specialisation.
430 %----------------------------------------------------------------------
433 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
434 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
438 They have no free type variables, so if you are making a
439 type-variable substitution you don't need to look inside them.
441 They are constants, so they are not free variables. (When the STG
442 machine makes a closure, it puts all the free variables in the
443 closure; the above are not required.)
445 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
446 properties, but they may not.
449 %************************************************************************
451 \subsection[Id-general-funs]{General @Id@-related functions}
453 %************************************************************************
456 unsafeGenId2Id :: GenId ty -> Id
457 unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i
459 isDataCon id = is_data (unsafeGenId2Id id)
461 is_data (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = True
462 is_data (Id _ _ (TupleConId _ _) _ _) = True
463 is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec
464 is_data other = False
467 isTupleCon id = is_tuple (unsafeGenId2Id id)
469 is_tuple (Id _ _ (TupleConId _ _) _ _) = True
470 is_tuple (Id _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
471 is_tuple other = False
474 isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _)
475 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
476 Just (unspec, ty_maybes)
477 isSpecId_maybe other_id
480 isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _)
482 isSpecPragmaId_maybe other_id
487 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a
488 nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be
489 defined at top level (returns @True@). This is used to decide whether
490 the @Id@ is a candidate free variable. NB: you are only {\em sure}
491 about something if it returns @True@!
494 toplevelishId :: Id -> Bool
495 idHasNoFreeTyVars :: Id -> Bool
497 toplevelishId (Id _ _ details _ _)
500 chk (DataConId _ _ _ _ _ _ _ _) = True
501 chk (TupleConId _ _) = True
502 chk (RecordSelId _) = True
503 chk (ImportedId _) = True
504 chk (PreludeId _) = True
505 chk (TopLevId _) = True -- NB: see notes
506 chk (SuperDictSelId _ _) = True
507 chk (MethodSelId _ _) = True
508 chk (DefaultMethodId _ _ _) = True
509 chk (DictFunId _ _ _ _) = True
510 chk (ConstMethodId _ _ _ _ _) = True
511 chk (SpecId unspec _ _) = toplevelishId unspec
512 -- depends what the unspecialised thing is
513 chk (WorkerId unwrkr) = toplevelishId unwrkr
514 chk (InstId _ _) = False -- these are local
515 chk (LocalId _ _) = False
516 chk (SysLocalId _ _) = False
517 chk (SpecPragmaId _ _ _) = False
519 idHasNoFreeTyVars (Id _ _ details _ info)
522 chk (DataConId _ _ _ _ _ _ _ _) = True
523 chk (TupleConId _ _) = True
524 chk (RecordSelId _) = True
525 chk (ImportedId _) = True
526 chk (PreludeId _) = True
527 chk (TopLevId _) = True
528 chk (SuperDictSelId _ _) = True
529 chk (MethodSelId _ _) = True
530 chk (DefaultMethodId _ _ _) = True
531 chk (DictFunId _ _ _ _) = True
532 chk (ConstMethodId _ _ _ _ _) = True
533 chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
534 chk (InstId _ no_free_tvs) = no_free_tvs
535 chk (SpecId _ _ no_free_tvs) = no_free_tvs
536 chk (LocalId _ no_free_tvs) = no_free_tvs
537 chk (SysLocalId _ no_free_tvs) = no_free_tvs
538 chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
542 isTopLevId (Id _ _ (TopLevId _) _ _) = True
543 isTopLevId other = False
545 isImportedId (Id _ _ (ImportedId _) _ _) = True
546 isImportedId other = False
548 isBottomingId (Id _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
550 isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
551 isSysLocalId other = False
553 isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True
554 isSpecPragmaId other = False
556 isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True
557 isMethodSelId _ = False
559 isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True
560 isDefaultMethodId other = False
562 isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _)
563 = Just (cls, clsop, err)
564 isDefaultMethodId_maybe other = Nothing
566 isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True
567 isDictFunId other = False
569 isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True
570 isConstMethodId other = False
572 isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _)
573 = Just (cls, ty, clsop)
574 isConstMethodId_maybe other = Nothing
576 isSuperDictSelId_maybe (Id _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
577 isSuperDictSelId_maybe other_id = Nothing
579 isWorkerId (Id _ _ (WorkerId _) _ _) = True
580 isWorkerId other = False
583 isWrapperId id = workerExists (getIdStrictness id)
589 pprIdInUnfolding :: IdSet -> Id -> Pretty
591 pprIdInUnfolding in_scopes v
596 if v `elementOfUniqSet` in_scopes then
597 pprUnique (idUnique v)
599 -- ubiquitous Ids with special syntax:
600 else if v == nilDataCon then
602 else if isTupleCon v then
603 ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
605 -- ones to think about:
608 (Id _ _ v_details _ _) = v
611 -- these ones must have been exported by their original module
612 ImportedId _ -> pp_full_name
613 PreludeId _ -> pp_full_name
615 -- these ones' exportedness checked later...
616 TopLevId _ -> pp_full_name
617 DataConId _ _ _ _ _ _ _ _ -> pp_full_name
619 RecordSelId lbl -> ppr sty lbl
621 -- class-ish things: class already recorded as "mentioned"
623 -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
625 -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
626 DefaultMethodId c o _
627 -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
629 -- instance-ish things: should we try to figure out
630 -- *exactly* which extra instances have to be exported? (ToDo)
632 -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
633 ConstMethodId c t o _ _
634 -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
636 -- specialisations and workers
637 SpecId unspec ty_maybes _
639 pp = pprIdInUnfolding in_scopes unspec
641 ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
642 ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
647 pp = pprIdInUnfolding in_scopes unwrkr
649 ppBeside (ppPStr SLIT("_WRKR_ ")) pp
651 -- anything else? we're nae interested
652 other_id -> panic "pprIdInUnfolding:mystery Id"
654 ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
658 (m_str, n_str) = getOrigName v
661 if isAvarop n_str || isAconop n_str then
662 ppBesides [ppLparen, ppPStr n_str, ppRparen]
666 if isPreludeDefined v then
669 ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
671 pp_class :: Class -> Pretty
672 pp_class_op :: ClassOp -> Pretty
673 pp_type :: Type -> Pretty
674 pp_ty_maybe :: Maybe Type -> Pretty
676 pp_class clas = ppr ppr_Unfolding clas
677 pp_class_op op = ppr ppr_Unfolding op
679 pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
681 pp_ty_maybe Nothing = ppPStr SLIT("_N_")
682 pp_ty_maybe (Just t) = pp_type t
686 @whatsMentionedInId@ ferrets out the types/classes/instances on which
687 this @Id@ depends. If this Id is to appear in an interface, then
688 those entities had Jolly Well be in scope. Someone else up the
689 call-tree decides that.
694 :: IdSet -- Ids known to be in scope
695 -> Id -- Id being processed
696 -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
698 whatsMentionedInId in_scopes v
703 = getMentionedTyConsAndClassesFromType v_ty
705 result0 id_bag = (id_bag, tycons, clss)
708 = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
709 tcs `unionBags` tycons,
713 if v `elementOfUniqSet` in_scopes then
714 result0 emptyBag -- v not added to "mentioned"
716 -- ones to think about:
719 (Id _ _ v_details _ _) = v
722 -- specialisations and workers
723 SpecId unspec ty_maybes _
725 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
727 result1 ids2 tcs2 cs2
731 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
733 result1 ids2 tcs2 cs2
735 anything_else -> result0 (unitBag v) -- v is added to "mentioned"
739 Tell them who my wrapper function is.
742 myWrapperMaybe :: Id -> Maybe Id
744 myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
745 myWrapperMaybe other_id = Nothing
750 unfoldingUnfriendlyId -- return True iff it is definitely a bad
751 :: Id -- idea to export an unfolding that
752 -> Bool -- mentions this Id. Reason: it cannot
753 -- possibly be seen in another module.
755 unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
758 unfoldingUnfriendlyId id
759 | not (externallyVisibleId id) -- that settles that...
762 unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _)
763 = class_thing wrapper
765 -- "class thing": If we're going to use this worker Id in
766 -- an interface, we *have* to be able to untangle the wrapper's
767 -- strictness when reading it back in. At the moment, this
768 -- is not always possible: in precisely those cases where
769 -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
771 class_thing (Id _ _ (SuperDictSelId _ _) _ _) = True
772 class_thing (Id _ _ (MethodSelId _ _) _ _) = True
773 class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True
774 class_thing other = False
776 unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _)
777 -- a SPEC of a DictFunId can end up w/ gratuitous
778 -- TyVar(Templates) in the i/face; only a problem
779 -- if -fshow-pragma-name-errs; but we can do without the pain.
780 -- A HACK in any case (WDP 94/05/02)
781 = naughty_DictFunId dfun
783 unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
784 = naughty_DictFunId dfun -- similar deal...
786 unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
788 naughty_DictFunId :: IdDetails -> Bool
789 -- True <=> has a TyVar(Template) in the "type" part of its "name"
791 naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
792 naughty_DictFunId (DictFunId _ ty _ _)
793 = not (isGroundTy ty)
797 @externallyVisibleId@: is it true that another module might be
798 able to ``see'' this Id?
800 We need the @toplevelishId@ check as well as @isExported@ for when we
801 compile instance declarations in the prelude. @DictFunIds@ are
802 ``exported'' if either their class or tycon is exported, but, in
803 compiling the prelude, the compiler may not recognise that as true.
806 externallyVisibleId :: Id -> Bool
808 externallyVisibleId id@(Id _ _ details _ _)
809 = if isLocallyDefined id then
810 toplevelishId id && isExported id && not (weird_datacon details)
812 not (weird_tuplecon details)
813 -- if visible here, it must be visible elsewhere, too.
815 -- If it's a DataCon, it's not enough to know it (meaning
816 -- its TyCon) is exported; we need to know that it might
817 -- be visible outside. Consider:
819 -- data Foo a = Mumble | BigFoo a WeirdLocalType
821 -- We can't tell the outside world *anything* about Foo, because
822 -- of WeirdLocalType; but we need to know this when asked if
823 -- "Mumble" is externally visible...
826 weird_datacon (DataConId _ _ _ _ _ _ _ tycon)
827 = maybeToBool (maybePurelyLocalTyCon tycon)
829 weird_datacon not_a_datacon_therefore_not_weird = False
831 weird_tuplecon (TupleConId _ arity)
832 = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
833 weird_tuplecon _ = False
837 idWantsToBeINLINEd :: Id -> Bool
839 idWantsToBeINLINEd (Id _ _ _ IWantToBeINLINEd _) = True
840 idWantsToBeINLINEd _ = False
843 For @unlocaliseId@: See the brief commentary in
844 \tr{simplStg/SimplStg.lhs}.
848 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
850 unlocaliseId mod (Id u ty info (TopLevId fn))
851 = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
853 unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
854 = --false?: ASSERT(no_ftvs)
856 full_name = unlocaliseShortName mod u sn
858 Just (Id u ty info (TopLevId full_name))
860 unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
861 = --false?: on PreludeGlaST: ASSERT(no_ftvs)
863 full_name = unlocaliseShortName mod u sn
865 Just (Id u ty info (TopLevId full_name))
867 unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
868 = case unlocalise_parent mod u unspec of
870 Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))
872 unlocaliseId mod (Id u ty info (WorkerId unwrkr))
873 = case unlocalise_parent mod u unwrkr of
875 Just xx -> Just (Id u ty info (WorkerId xx))
877 unlocaliseId mod (Id u ty info (InstId name no_ftvs))
878 = Just (Id u ty info (TopLevId full_name))
879 -- type might be wrong, but it hardly matters
880 -- at this stage (just before printing C) ToDo
882 name = getLocalName name
883 full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
885 unlocaliseId mod other_id = Nothing
888 -- we have to be Very Careful for workers/specs of
891 unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs))
892 = --false?: ASSERT(no_ftvs)
894 full_name = unlocaliseShortName mod uniq sn
896 Just (Id uniq ty info (TopLevId full_name))
898 unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
899 = --false?: ASSERT(no_ftvs)
901 full_name = unlocaliseShortName mod uniq sn
903 Just (Id uniq ty info (TopLevId full_name))
905 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
906 -- we're OK otherwise
910 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
911 `Top-levelish Ids'' cannot have any free type variables, so applying
912 the type-env cannot have any effect. (NB: checked in CoreLint?)
914 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
915 former ``should be'' the usual crunch point.
918 type TypeEnv = TyVarEnv Type
920 applyTypeEnvToId :: TypeEnv -> Id -> Id
922 applyTypeEnvToId type_env id@(Id _ ty _ _ _)
923 | idHasNoFreeTyVars id
926 = apply_to_Id ( \ ty ->
927 applyTypeEnvToTy type_env ty
932 apply_to_Id :: (Type -> Type)
936 apply_to_Id ty_fn (Id u ty details prag info)
940 Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
942 apply_to_details (SpecId unspec ty_maybes no_ftvs)
944 new_unspec = apply_to_Id ty_fn unspec
945 new_maybes = map apply_to_maybe ty_maybes
947 SpecId new_unspec new_maybes (no_free_tvs ty)
948 -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
950 apply_to_maybe Nothing = Nothing
951 apply_to_maybe (Just ty) = Just (ty_fn ty)
953 apply_to_details (WorkerId unwrkr)
955 new_unwrkr = apply_to_Id ty_fn unwrkr
959 apply_to_details other = other
962 Sadly, I don't think the one using the magic typechecker substitution
963 can be done with @apply_to_Id@. Here we go....
965 Strictness is very important here. We can't leave behind thunks
966 with pointers to the substitution: it {\em must} be single-threaded.
970 applySubstToId :: Subst -> Id -> (Subst, Id)
972 applySubstToId subst id@(Id u ty info details)
973 -- *cannot* have a "idHasNoFreeTyVars" get-out clause
974 -- because, in the typechecker, we are still
975 -- *concocting* the types.
976 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
977 case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
978 case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
979 (s4, Id u new_ty new_info new_details) }}}
981 apply_to_details subst _ (InstId inst no_ftvs)
982 = case (applySubstToInst subst inst) of { (s2, new_inst) ->
983 (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
985 apply_to_details subst new_ty (SpecId unspec ty_maybes _)
986 = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
987 case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
988 (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
989 -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
991 apply_to_maybe subst Nothing = (subst, Nothing)
992 apply_to_maybe subst (Just ty)
993 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
996 apply_to_details subst _ (WorkerId unwrkr)
997 = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
998 (s2, WorkerId new_unwrkr) }
1000 apply_to_details subst _ other = (subst, other)
1005 getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
1007 getIdNamePieces show_uniqs id
1008 = get (unsafeGenId2Id id)
1010 get (Id u _ details _ _)
1012 DataConId n _ _ _ _ _ _ _ ->
1013 case (nameOrigName n) of { (mod, name) ->
1014 if isPreludeDefinedName n then [name] else [mod, name] }
1016 TupleConId n _ -> [snd (nameOrigName n)]
1018 RecordSelId lbl -> panic "getIdNamePieces:RecordSelId"
1020 ImportedId n -> get_fullname_pieces n
1021 PreludeId n -> get_fullname_pieces n
1022 TopLevId n -> get_fullname_pieces n
1024 SuperDictSelId c sc ->
1025 case (getOrigName c) of { (c_mod, c_name) ->
1026 case (getOrigName sc) of { (sc_mod, sc_name) ->
1028 c_bits = if isPreludeDefined c
1030 else [c_mod, c_name]
1032 sc_bits= if isPreludeDefined sc
1034 else [sc_mod, sc_name]
1036 [SLIT("sdsel")] ++ c_bits ++ sc_bits }}
1038 MethodSelId clas op ->
1039 case (getOrigName clas) of { (c_mod, c_name) ->
1040 case (getClassOpString op) of { op_name ->
1041 if isPreludeDefined clas
1043 else [c_mod, c_name, op_name]
1046 DefaultMethodId clas op _ ->
1047 case (getOrigName clas) of { (c_mod, c_name) ->
1048 case (getClassOpString op) of { op_name ->
1049 if isPreludeDefined clas
1050 then [SLIT("defm"), op_name]
1051 else [SLIT("defm"), c_mod, c_name, op_name] }}
1053 DictFunId c ty _ _ ->
1054 case (getOrigName c) of { (c_mod, c_name) ->
1056 c_bits = if isPreludeDefined c
1058 else [c_mod, c_name]
1060 ty_bits = getTypeString ty
1062 [SLIT("dfun")] ++ c_bits ++ ty_bits }
1064 ConstMethodId c ty o _ _ ->
1065 case (getOrigName c) of { (c_mod, c_name) ->
1066 case (getTypeString ty) of { ty_bits ->
1067 case (getClassOpString o) of { o_name ->
1068 case (if isPreludeDefined c
1070 else [c_mod, c_name]) of { c_bits ->
1071 [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
1073 -- if the unspecialised equiv is "top-level",
1074 -- the name must be concocted from its name and the
1075 -- names of the types to which specialised...
1077 SpecId unspec ty_maybes _ ->
1078 get unspec ++ (if not (toplevelishId unspec)
1080 else concat (map typeMaybeString ty_maybes))
1083 get unwrkr ++ (if not (toplevelishId unwrkr)
1087 LocalId n _ -> let local = getLocalName n in
1088 if show_uniqs then [local, showUnique u] else [local]
1089 InstId n _ -> [getLocalName n, showUnique u]
1090 SysLocalId n _ -> [getLocalName n, showUnique u]
1091 SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
1093 get_fullname_pieces :: Name -> [FAST_STRING]
1094 get_fullname_pieces n
1095 = BIND (nameOrigName n) _TO_ (mod, name) ->
1096 if isPreludeDefinedName n
1102 %************************************************************************
1104 \subsection[Id-type-funs]{Type-related @Id@ functions}
1106 %************************************************************************
1109 idType :: GenId ty -> ty
1111 idType (Id _ ty _ _ _) = ty
1116 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1118 getMentionedTyConsAndClassesFromId id
1119 = getMentionedTyConsAndClassesFromType (idType id)
1124 idPrimRep i = typePrimRep (idType i)
1129 getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
1130 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
1131 getInstIdModule other = panic "Id:getInstIdModule"
1135 %************************************************************************
1137 \subsection[Id-overloading]{Functions related to overloading}
1139 %************************************************************************
1142 mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
1143 mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
1144 mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
1146 mkDictFunId u c ity full_ty from_here mod info
1147 = Id u full_ty (DictFunId c ity from_here mod) NoPragmaInfo info
1149 mkConstMethodId u c op ity full_ty from_here mod info
1150 = Id u full_ty (ConstMethodId c ity op from_here mod) NoPragmaInfo info
1152 mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
1154 mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo
1157 getConstMethodId clas op ty
1158 = -- constant-method info is hidden in the IdInfo of
1159 -- the class-op id (as mentioned up above).
1161 sel_id = getMethodSelId clas op
1163 case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1165 Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
1166 ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1167 ppr PprDebug sel_id],
1168 ppStr "(This can arise if an interface pragma refers to an instance",
1169 ppStr "but there is no imported interface which *defines* that instance.",
1170 ppStr "The info above, however ugly, should indicate what else you need to import."
1175 %************************************************************************
1177 \subsection[local-funs]{@LocalId@-related functions}
1179 %************************************************************************
1182 mkImported n ty info = Id (nameUnique n) ty (ImportedId n) NoPragmaInfo info
1183 mkPreludeId n ty info = Id (nameUnique n) ty (PreludeId n) NoPragmaInfo info
1186 updateIdType :: Id -> Type -> Id
1187 updateIdType (Id u _ info details) ty = Id u ty info details
1192 type MyTy a b = GenType (GenTyVar a) b
1193 type MyId a b = GenId (MyTy a b)
1195 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1197 -- SysLocal: for an Id being created by the compiler out of thin air...
1198 -- UserLocal: an Id with a name the user might recognize...
1199 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1201 mkSysLocal str uniq ty loc
1202 = Id uniq ty (SysLocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1204 mkUserLocal str uniq ty loc
1205 = Id uniq ty (LocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1207 -- mkUserId builds a local or top-level Id, depending on the name given
1208 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1209 mkUserId name ty pragma_info
1211 = Id (nameUnique name) ty (LocalId name (no_free_tvs ty)) pragma_info noIdInfo
1213 = Id (nameUnique name) ty
1214 (if isLocallyDefinedName name then TopLevId name else ImportedId name)
1215 pragma_info noIdInfo
1222 -- for a SpecPragmaId being created by the compiler out of thin air...
1223 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1224 mkSpecPragmaId str uniq ty specid loc
1225 = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
1228 mkSpecId u unspec ty_maybes ty info
1229 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1230 Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1232 -- Specialised version of constructor: only used in STG and code generation
1233 -- Note: The specialsied Id has the same unique as the unspeced Id
1235 mkSameSpecCon ty_maybes unspec@(Id u ty info details)
1236 = ASSERT(isDataCon unspec)
1237 ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1238 Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1240 new_ty = specialiseTy ty ty_maybes 0
1242 localiseId :: Id -> Id
1243 localiseId id@(Id u ty info details)
1244 = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
1246 name = getOccName id
1250 mkIdWithNewUniq :: Id -> Unique -> Id
1252 mkIdWithNewUniq (Id _ ty details prag info) uniq
1253 = Id uniq ty details prag info
1256 Make some local @Ids@ for a template @CoreExpr@. These have bogus
1257 @Uniques@, but that's OK because the templates are supposed to be
1258 instantiated before use.
1260 mkTemplateLocals :: [Type] -> [Id]
1261 mkTemplateLocals tys
1262 = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1263 (getBuiltinUniques (length tys))
1268 getIdInfo :: GenId ty -> IdInfo
1269 getPragmaInfo :: GenId ty -> PragmaInfo
1271 getIdInfo (Id _ _ _ _ info) = info
1272 getPragmaInfo (Id _ _ _ info _) = info
1275 replaceIdInfo :: Id -> IdInfo -> Id
1277 replaceIdInfo (Id u ty _ details) info = Id u ty info details
1279 selectIdInfoForSpecId :: Id -> IdInfo
1280 selectIdInfoForSpecId unspec
1281 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1282 noIdInfo `addInfo_UF` getIdUnfolding unspec
1286 %************************************************************************
1288 \subsection[Id-arities]{Arity-related functions}
1290 %************************************************************************
1292 For locally-defined Ids, the code generator maintains its own notion
1293 of their arities; so it should not be asking... (but other things
1294 besides the code-generator need arity info!)
1297 getIdArity :: Id -> ArityInfo
1298 getIdArity (Id _ _ _ _ id_info) = getInfo id_info
1300 dataConArity :: DataCon -> Int
1301 dataConArity id@(Id _ _ _ _ id_info)
1302 = ASSERT(isDataCon id)
1303 case (arityMaybe (getInfo id_info)) of
1304 Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1307 addIdArity :: Id -> Int -> Id
1308 addIdArity (Id u ty details pinfo info) arity
1309 = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
1312 %************************************************************************
1314 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1316 %************************************************************************
1320 -> [StrictnessMark] -> [FieldLabel]
1321 -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1324 -- can get the tag and all the pieces of the type from the Type
1326 mkDataCon n stricts fields tvs ctxt args_tys tycon
1327 = ASSERT(length stricts == length args_tys)
1330 -- NB: data_con self-recursion; should be OK as tags are not
1331 -- looked at until late in the game.
1335 (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon)
1339 data_con_tag = position_within fIRST_TAG data_con_family
1341 data_con_family = tyConDataCons tycon
1343 position_within :: Int -> [Id] -> Int
1345 position_within acc (c:cs)
1346 = if c == data_con then acc else position_within (acc+1) cs
1348 position_within acc []
1349 = panic "mkDataCon: con not found in family"
1353 = mkSigmaTy tvs ctxt
1354 (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1356 datacon_info = noIdInfo `addInfo_UF` unfolding
1357 `addInfo` mkArityInfo arity
1358 --ToDo: `addInfo` specenv
1360 arity = length args_tys
1367 -- else -- do some business...
1369 (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1370 tyvar_tys = mkTyVarTys tyvars
1372 BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1374 mkUnfolding EssentialUnfolding -- for data constructors
1375 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1378 mk_uf_bits tvs ctxt arg_tys tycon
1380 (inst_env, tyvars, tyvar_tys)
1381 = instantiateTyVarTemplates tvs
1382 (map getItsUnique tvs)
1384 -- the "context" and "arg_tys" have TyVarTemplates in them, so
1385 -- we instantiate those types to have the right TyVars in them
1387 BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1388 _TO_ inst_dict_tys ->
1389 BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys ->
1391 -- We can only have **ONE** call to mkTemplateLocals here;
1392 -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1393 -- (Mega-Sigh) [ToDo]
1394 BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
1396 BIND (splitAt (length ctxt) all_vars) _TO_ (dict_vars, vars) ->
1398 (tyvars, dict_vars, vars)
1401 -- these are really dubious Types, but they are only to make the
1402 -- binders for the lambdas for tossed-away dicts.
1403 ctxt_ty (clas, ty) = mkDictTy clas ty
1408 mkTupleCon :: Arity -> Id
1411 = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info
1413 n = panic "mkTupleCon: its Name (Id)"
1414 unique = mkTupleDataConUnique arity
1415 ty = mkSigmaTy tyvars []
1416 (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1417 tycon = mkTupleTyCon arity
1418 tyvars = take arity alphaTyVars
1419 tyvar_tys = mkTyVarTys tyvars
1422 = noIdInfo `addInfo_UF` unfolding
1423 `addInfo` mkArityInfo arity
1424 --LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1431 -- else -- do some business...
1433 (tyvars, dict_vars, vars) = mk_uf_bits arity
1434 tyvar_tys = mkTyVarTys tyvars
1436 BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1439 EssentialUnfolding -- data constructors
1440 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1444 = BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
1448 tyvar_tmpls = take arity alphaTyVars
1449 (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
1453 fIRST_TAG = 1 -- Tags allocated from here for real constructors
1457 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1458 dataConTag (Id _ _ (DataConId _ tag _ _ _ _ _ _) _ _) = tag
1459 dataConTag (Id _ _ (TupleConId _ _) _ _) = fIRST_TAG
1460 dataConTag (Id _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
1462 dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
1463 dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon
1464 dataConTyCon (Id _ _ (TupleConId _ a) _ _) = mkTupleTyCon a
1466 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1467 -- will panic if not a DataCon
1469 dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1470 = (tyvars, theta_ty, arg_tys, tycon)
1472 dataConSig (Id _ _ (TupleConId _ arity) _ _)
1473 = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1475 tyvars = take arity alphaTyVars
1476 tyvar_tys = mkTyVarTys tyvars
1478 dataConFieldLabels :: DataCon -> [FieldLabel]
1479 dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields
1483 mkRecordSelId field_label selector_ty
1484 = Id (nameUnique name)
1486 (RecordSelId field_label)
1490 name = fieldLabelName field_label
1492 recordSelectorFieldLabel :: Id -> FieldLabel
1493 recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl
1497 dataConTyCon (Id _ _ _ (SpecId unspec tys _))
1498 = mkSpecTyCon (dataConTyCon unspec) tys
1500 dataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
1501 = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
1503 (tyvars, theta_ty, arg_tys, tycon) = dataConSig unspec
1505 ty_env = tyvars `zip` ty_maybes
1507 spec_tyvars = foldr nothing_tyvars [] ty_env
1508 nothing_tyvars (tyvar, Nothing) l = tyvar : l
1509 nothing_tyvars (tyvar, Just ty) l = l
1511 spec_env = foldr just_env [] ty_env
1512 just_env (tyvar, Nothing) l = l
1513 just_env (tyvar, Just ty) l = (tyvar, ty) : l
1514 spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
1516 spec_theta_ty = if null theta_ty then []
1517 else panic "dataConSig:ThetaTy:SpecDataCon"
1518 spec_tycon = mkSpecTyCon tycon ty_maybes
1523 @getInstantiatedDataConSig@ takes a constructor and some types to which
1524 it is applied; it returns its signature instantiated to these types.
1527 getInstantiatedDataConSig ::
1528 DataCon -- The data constructor
1529 -- Not a specialised data constructor
1530 -> [TauType] -- Types to which applied
1531 -- Must be fully applied i.e. contain all types of tycon
1532 -> ([TauType], -- Types of dict args
1533 [TauType], -- Types of regular args
1534 TauType -- Type of result
1537 getInstantiatedDataConSig data_con inst_tys
1538 = ASSERT(isDataCon data_con)
1540 (tvs, theta, arg_tys, tycon) = dataConSig data_con
1542 inst_env = ASSERT(length tvs == length inst_tys)
1545 theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ]
1546 cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ]
1547 result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys)
1549 -- Are the first/third results ever used?
1550 (theta_tys, cmpnt_tys, result_ty)
1553 Data type declarations are of the form:
1555 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1557 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1558 @C1 x y z@, we want a function binding:
1560 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1562 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1563 2nd-order polymorphic lambda calculus with explicit types.
1565 %************************************************************************
1567 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1569 %************************************************************************
1571 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1572 and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
1573 @TyVars@ don't really have to be new, because we are only producing a
1576 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1579 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1580 EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the
1581 example above: a, b, and x, y, z], which is enough (in the important
1582 \tr{DsExpr} case). (The middle set of @Ids@ is binders for any
1583 dictionaries, in the even of an overloaded data-constructor---none at
1587 getIdUnfolding :: Id -> UnfoldingDetails
1589 getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info
1592 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1593 addIdUnfolding id@(Id u ty info details) unfold_details
1595 case (isLocallyDefined id, unfold_details) of
1596 (_, NoUnfoldingDetails) -> True
1597 (True, IWantToBeINLINEd _) -> True
1598 (False, IWantToBeINLINEd _) -> False -- v bad
1602 Id u ty (info `addInfo_UF` unfold_details) details
1606 In generating selector functions (take a dictionary, give back one
1607 component...), we need to what out for the nothing-to-select cases (in
1608 which case the ``selector'' is just an identity function):
1610 class Eq a => Foo a { } # the superdict selector for "Eq"
1612 class Foo a { op :: Complex b => c -> b -> a }
1613 # the method selector for "op";
1614 # note local polymorphism...
1617 %************************************************************************
1619 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1621 %************************************************************************
1624 getIdDemandInfo :: Id -> DemandInfo
1625 getIdDemandInfo (Id _ _ _ _ info) = getInfo info
1627 addIdDemandInfo :: Id -> DemandInfo -> Id
1628 addIdDemandInfo (Id u ty details prags info) demand_info
1629 = Id u ty details prags (info `addInfo` demand_info)
1633 getIdUpdateInfo :: Id -> UpdateInfo
1634 getIdUpdateInfo (Id _ _ _ _ info) = getInfo info
1636 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1637 addIdUpdateInfo (Id u ty details prags info) upd_info
1638 = Id u ty details prags (info `addInfo` upd_info)
1643 getIdArgUsageInfo :: Id -> ArgUsageInfo
1644 getIdArgUsageInfo (Id u ty info details) = getInfo info
1646 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1647 addIdArgUsageInfo (Id u ty info details) au_info
1648 = Id u ty (info `addInfo` au_info) details
1654 getIdFBTypeInfo :: Id -> FBTypeInfo
1655 getIdFBTypeInfo (Id u ty info details) = getInfo info
1657 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1658 addIdFBTypeInfo (Id u ty info details) upd_info
1659 = Id u ty (info `addInfo` upd_info) details
1665 getIdSpecialisation :: Id -> SpecEnv
1666 getIdSpecialisation (Id _ _ _ _ info) = getInfo info
1668 addIdSpecialisation :: Id -> SpecEnv -> Id
1669 addIdSpecialisation (Id u ty details prags info) spec_info
1670 = Id u ty details prags (info `addInfo` spec_info)
1674 Strictness: we snaffle the info out of the IdInfo.
1677 getIdStrictness :: Id -> StrictnessInfo
1679 getIdStrictness (Id _ _ _ _ info) = getInfo info
1681 addIdStrictness :: Id -> StrictnessInfo -> Id
1683 addIdStrictness (Id u ty details prags info) strict_info
1684 = Id u ty details prags (info `addInfo` strict_info)
1687 %************************************************************************
1689 \subsection[Id-comparison]{Comparison functions for @Id@s}
1691 %************************************************************************
1693 Comparison: equality and ordering---this stuff gets {\em hammered}.
1696 cmpId (Id u1 _ _ _ _) (Id u2 _ _ _ _) = cmp u1 u2
1697 -- short and very sweet
1701 instance Ord3 (GenId ty) where
1704 instance Eq (GenId ty) where
1705 a == b = case cmpId a b of { EQ_ -> True; _ -> False }
1706 a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
1708 instance Ord (GenId ty) where
1709 a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
1710 a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
1711 a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
1712 a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
1713 _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1716 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1717 account when comparing two data constructors. We need to do this
1718 because a specialised data constructor has the same Unique as its
1719 unspecialised counterpart.
1722 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1724 cmpId_withSpecDataCon id1 id2
1725 | eq_ids && isDataCon id1 && isDataCon id2
1726 = cmpEqDataCon id1 id2
1731 cmp_ids = cmpId id1 id2
1732 eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
1734 cmpEqDataCon (Id _ _ (SpecId _ mtys1 _) _ _) (Id _ _ (SpecId _ mtys2 _) _ _)
1735 = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1737 cmpEqDataCon _ (Id _ _ (SpecId _ _ _) _ _) = LT_
1738 cmpEqDataCon (Id _ _ (SpecId _ _ _) _ _) _ = GT_
1739 cmpEqDataCon _ _ = EQ_
1742 %************************************************************************
1744 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1746 %************************************************************************
1749 instance Outputable ty => Outputable (GenId ty) where
1750 ppr sty id = pprId sty id
1752 -- and a SPECIALIZEd one:
1753 instance Outputable {-Id, i.e.:-}(GenId Type) where
1754 ppr sty id = pprId sty id
1756 showId :: PprStyle -> Id -> String
1757 showId sty id = ppShow 80 (pprId sty id)
1760 -- for DictFuns (instances) and const methods (instance code bits we
1761 -- can call directly): exported (a) if *either* the class or
1762 -- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
1763 -- class and tycon are from PreludeCore [non-std, but convenient]
1764 -- *and* the thing was defined in this module.
1766 instance_export_flag :: Class -> Type -> Bool -> ExportFlag
1768 instance_export_flag clas inst_ty from_here
1769 = panic "Id:instance_export_flag"
1771 = if instanceIsExported clas inst_ty from_here
1777 Default printing code (not used for interfaces):
1779 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1783 pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
1787 pieces_to_print -- maybe use Unique only
1788 = if isSysLocalId id then tail pieces else pieces
1790 ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
1794 PprForAsm _ _ -> for_code
1795 PprInterface -> ppr other_sty occur_name
1796 PprForUser -> ppr other_sty occur_name
1797 PprUnfolding -> qualified_name pieces
1798 PprDebug -> qualified_name pieces
1799 PprShowAll -> ppBesides [qualified_name pieces,
1802 ppr other_sty (idType id),
1803 ppIdInfo other_sty (unsafeGenId2Id id) True
1804 (\x->x) nullIdEnv (getIdInfo id),
1805 ppPStr SLIT("-}") ])]
1807 occur_name = getOccName id `appendRdr`
1808 (if not (isSysLocalId id)
1810 else SLIT(".") _APPEND_ (showUnique (idUnique id)))
1812 qualified_name pieces
1813 = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
1815 pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add
1816 pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = ppNil
1817 pp_uniq (Id _ _ (TupleConId _ _) _ _) = ppNil
1818 pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere
1819 pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil
1820 pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil
1821 pp_uniq (Id _ _ (InstId _ _) _ _) = ppNil
1822 pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (idUnique other_id), ppPStr SLIT("-}")]
1824 -- print PprDebug Ids with # afterwards if they are of primitive type.
1825 pp_ubxd pretty = pretty
1827 {- LATER: applying isPrimType restricts type
1828 pp_ubxd pretty = if isPrimType (idType id)
1829 then ppBeside pretty (ppChar '#')
1836 idUnique (Id u _ _ _ _) = u
1838 instance Uniquable (GenId ty) where
1841 instance NamedThing (GenId ty) where
1842 getName this_id@(Id u _ details _ _)
1845 get (LocalId n _) = n
1846 get (SysLocalId n _) = n
1847 get (SpecPragmaId n _ _)= n
1848 get (ImportedId n) = n
1849 get (PreludeId n) = n
1850 get (TopLevId n) = n
1851 get (InstId n _) = n
1852 get (DataConId n _ _ _ _ _ _ _) = n
1853 get (TupleConId n _) = n
1854 get (RecordSelId l) = getName l
1855 -- get _ = pprPanic "Id.Id.NamedThing.getName:" (pprId PprDebug this_id)
1858 get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ???
1859 (mod, _) -> (mod, getClassOpString op)
1861 get (SpecId unspec ty_maybes _)
1862 = BIND getOrigName unspec _TO_ (mod, unspec_nm) ->
1863 BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
1866 (if not (toplevelishId unspec)
1872 get (WorkerId unwrkr)
1873 = BIND getOrigName unwrkr _TO_ (mod, unwrkr_nm) ->
1876 (if not (toplevelishId unwrkr)
1883 -- the remaining internally-generated flavours of
1884 -- Ids really do not have meaningful "original name" stuff,
1885 -- but we need to make up something (usually for debugging output)
1887 = BIND (getIdNamePieces True this_id) _TO_ (piece1:pieces) ->
1888 BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
1889 (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
1894 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1895 the @Uniques@ out of local @Ids@ given to it.
1897 %************************************************************************
1899 \subsection{@IdEnv@s and @IdSet@s}
1901 %************************************************************************
1904 type IdEnv elt = UniqFM elt
1906 nullIdEnv :: IdEnv a
1908 mkIdEnv :: [(GenId ty, a)] -> IdEnv a
1909 unitIdEnv :: GenId ty -> a -> IdEnv a
1910 addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
1911 growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
1912 growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1914 delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
1915 delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
1916 combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1917 mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
1918 modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
1919 rngIdEnv :: IdEnv a -> [a]
1921 isNullIdEnv :: IdEnv a -> Bool
1922 lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
1923 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1927 addOneToIdEnv = addToUFM
1928 combineIdEnvs = plusUFM_C
1929 delManyFromIdEnv = delListFromUFM
1930 delOneFromIdEnv = delFromUFM
1932 lookupIdEnv = lookupUFM
1935 nullIdEnv = emptyUFM
1939 growIdEnvList env pairs = plusUFM env (listToUFM pairs)
1940 isNullIdEnv env = sizeUFM env == 0
1941 lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
1943 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1944 -- modify function, and put it back.
1946 modifyIdEnv env mangle_fn key
1947 = case (lookupIdEnv env key) of
1949 Just xx -> addOneToIdEnv env key (mangle_fn xx)
1953 type GenIdSet ty = UniqSet (GenId ty)
1954 type IdSet = UniqSet (GenId Type)
1956 emptyIdSet :: GenIdSet ty
1957 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1958 unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1959 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1960 idSetToList :: GenIdSet ty -> [GenId ty]
1961 unitIdSet :: GenId ty -> GenIdSet ty
1962 addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
1963 elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
1964 minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1965 isEmptyIdSet :: GenIdSet ty -> Bool
1966 mkIdSet :: [GenId ty] -> GenIdSet ty
1968 emptyIdSet = emptyUniqSet
1969 unitIdSet = unitUniqSet
1970 addOneToIdSet = addOneToUniqSet
1971 intersectIdSets = intersectUniqSets
1972 unionIdSets = unionUniqSets
1973 unionManyIdSets = unionManyUniqSets
1974 idSetToList = uniqSetToList
1975 elementOfIdSet = elementOfUniqSet
1976 minusIdSet = minusUniqSet
1977 isEmptyIdSet = isEmptyUniqSet