2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[Id]{@Ids@: Value and constructor identifiers}
7 #include "HsVersions.h"
10 GenId, Id(..), -- Abstract
11 StrictnessMark(..), -- An enumaration
12 ConTag(..), DictVar(..), DictFun(..), DataCon(..),
15 mkSysLocal, mkUserLocal,
17 mkSpecId, mkSameSpecCon,
18 selectIdInfoForSpecId,
20 mkImported, mkPreludeId,
21 mkDataCon, mkTupleCon,
23 mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
24 mkConstMethodId, getConstMethodId,
27 mkId, mkDictFunId, mkInstId,
33 getIdInfo, replaceIdInfo,
35 idPrimRep, getInstIdModule,
36 getMentionedTyConsAndClassesFromId,
38 dataConTag, dataConStrictMarks,
39 dataConSig, dataConArgTys,
40 dataConTyCon, dataConArity,
43 recordSelectorFieldLabel,
46 isDataCon, isTupleCon,
47 isSpecId_maybe, isSpecPragmaId_maybe,
48 toplevelishId, externallyVisibleId,
49 isTopLevId, isWorkerId, isWrapperId,
50 isImportedId, isSysLocalId,
52 isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
55 isConstMethodId_maybe,
56 cmpId_withSpecDataCon,
59 unfoldingUnfriendlyId, -- ToDo: rm, eventually
61 -- dataConMentionsNonPreludeTyCon,
64 applySubstToId, applyTypeEnvToId,
65 -- not exported: apply_to_Id, -- please don't use this, generally
67 -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
68 getIdArity, addIdArity,
69 getIdDemandInfo, addIdDemandInfo,
70 getIdSpecialisation, addIdSpecialisation,
71 getIdStrictness, addIdStrictness,
72 getIdUnfolding, addIdUnfolding,
73 getIdUpdateInfo, addIdUpdateInfo,
74 getIdArgUsageInfo, addIdArgUsageInfo,
75 getIdFBTypeInfo, addIdFBTypeInfo,
76 -- don't export the types, lest OptIdInfo be dragged in!
84 -- "Environments" keyed off of Ids, and sets of Ids
86 lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
87 growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
88 delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
91 -- and to make the interface self-sufficient...
92 GenIdSet(..), IdSet(..)
96 import IdLoop -- for paranoia checking
97 import TyLoop -- for paranoia checking
100 import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
101 import CStrings ( identToC, cSEP )
103 import Maybes ( maybeToBool )
104 import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
105 isLocallyDefinedName, isPreludeDefinedName,
106 nameOrigName, mkTupleDataConName,
107 isAvarop, isAconop, getLocalName,
108 isLocallyDefined, isPreludeDefined,
109 getOrigName, getOccName,
110 isExported, ExportFlag(..),
113 import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
114 import PragmaInfo ( PragmaInfo(..) )
115 import PrelMods ( pRELUDE_BUILTIN )
116 import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
121 import SrcLoc ( mkBuiltinSrcLoc )
122 import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
123 import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
124 applyTyCon, isPrimType, instantiateTy,
125 tyVarsOfType, applyTypeEnvToTy, typePrimRep,
126 GenType, ThetaType(..), TauType(..), Type(..)
128 import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
130 import UniqSet -- practically all of it
131 import UniqSupply ( getBuiltinUniques )
132 import Unique ( pprUnique, showUnique,
133 Unique{-instance Ord3-}
135 import Util ( mapAccumL, nOfThem, zipEqual,
136 panic, panic#, pprPanic, assertPanic
140 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
143 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
144 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
145 strictness). The essential info about different kinds of @Ids@ is
148 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
152 Unique -- Key for fast comparison
153 ty -- Id's type; used all the time;
154 IdDetails -- Stuff about individual kinds of Ids.
155 PragmaInfo -- Properties of this Id requested by programmer
156 -- eg specialise-me, inline-me
157 IdInfo -- Properties of this Id deduced by compiler
161 data StrictnessMark = MarkedStrict | NotMarkedStrict
165 ---------------- Local values
167 = LocalId Name -- Local name; mentioned by the user
168 Bool -- True <=> no free type vars
170 | SysLocalId Name -- Local name; made up by the compiler
171 Bool -- as for LocalId
173 | SpecPragmaId Name -- Local name; introduced by the compiler
174 (Maybe Id) -- for explicit specid in pragma
175 Bool -- as for LocalId
177 ---------------- Global values
179 | ImportedId Name -- Global name (Imported or Implicit); Id imported from an interface
181 | PreludeId Name -- Global name (Builtin); Builtin prelude Ids
183 | TopLevId Name -- Global name (LocalDef); Top-level in the orig source pgm
184 -- (not moved there by transformations).
186 -- a TopLevId's type may contain free type variables, if
187 -- the monomorphism restriction applies.
189 ---------------- Data constructors
193 [StrictnessMark] -- Strict args; length = arity
194 [FieldLabel] -- Field labels for this constructor
196 [TyVar] [(Class,Type)] [Type] TyCon
198 -- forall tyvars . theta_ty =>
199 -- unitype_1 -> ... -> unitype_n -> tycon tyvars
204 | RecordSelId FieldLabel
206 ---------------- Things to do with overloading
208 | SuperDictSelId -- Selector for superclass dictionary
209 Class -- The class (input dict)
210 Class -- The superclass (result dict)
212 | MethodSelId Class -- An overloaded class operation, with
213 -- a fully polymorphic type. Its code
214 -- just selects a method from the
215 -- dictionary. The class.
216 ClassOp -- The operation
218 -- NB: The IdInfo for a MethodSelId has all the info about its
219 -- related "constant method Ids", which are just
220 -- specialisations of this general one.
222 | DefaultMethodId -- Default method for a particular class op
223 Class -- same class, <blah-blah> info as MethodSelId
224 ClassOp -- (surprise, surprise)
225 Bool -- True <=> I *know* this default method Id
226 -- is a generated one that just says
227 -- `error "No default method for <op>"'.
230 | DictFunId Class -- A DictFun is uniquely identified
231 Type -- by its class and type; this type has free type vars,
232 -- whose identity is irrelevant. Eg Class = Eq
234 -- The "a" is irrelevant. As it is too painful to
235 -- actually do comparisons that way, we kindly supply
236 -- a Unique for that purpose.
237 Bool -- True <=> from an instance decl in this mod
238 (Maybe Module) -- module where instance came from; Nothing => Prelude
241 | ConstMethodId -- A method which depends only on the type of the
242 -- instance, and not on any further dictionaries etc.
243 Class -- Uniquely identified by:
244 Type -- (class, type, classop) triple
246 Bool -- True => from an instance decl in this mod
247 (Maybe Module) -- module where instance came from; Nothing => Prelude
249 | InstId Name -- An instance of a dictionary, class operation,
250 -- or overloaded value (Local name)
251 Bool -- as for LocalId
253 | SpecId -- A specialisation of another Id
254 Id -- Id of which this is a specialisation
255 [Maybe Type] -- Types at which it is specialised;
256 -- A "Nothing" says this type ain't relevant.
257 Bool -- True <=> no free type vars; it's not enough
258 -- to know about the unspec version, because
259 -- we may specialise to a type w/ free tyvars
260 -- (i.e., in one of the "Maybe Type" dudes).
262 | WorkerId -- A "worker" for some other Id
263 Id -- Id for which this is a worker
273 DictFunIds are generated from instance decls.
278 instance Foo a => Foo [a] where
281 generates the dict fun id decl
283 dfun.Foo.[*] = \d -> ...
285 The dfun id is uniquely named by the (class, type) pair. Notice, it
286 isn't a (class,tycon) pair any more, because we may get manually or
287 automatically generated specialisations of the instance decl:
289 instance Foo [Int] where
296 The type variables in the name are irrelevant; we print them as stars.
299 Constant method ids are generated from instance decls where
300 there is no context; that is, no dictionaries are needed to
301 construct the method. Example
303 instance Foo Int where
306 Then we get a constant method
311 It is possible, albeit unusual, to have a constant method
312 for an instance decl which has type vars:
314 instance Foo [a] where
318 We get the constant method
322 So a constant method is identified by a class/op/type triple.
323 The type variables in the type are irrelevant.
326 For Ids whose names must be known/deducible in other modules, we have
327 to conjure up their worker's names (and their worker's worker's
328 names... etc) in a known systematic way.
331 %************************************************************************
333 \subsection[Id-documentation]{Documentation}
335 %************************************************************************
339 The @Id@ datatype describes {\em values}. The basic things we want to
340 know: (1)~a value's {\em type} (@idType@ is a very common
341 operation in the compiler); and (2)~what ``flavour'' of value it might
342 be---for example, it can be terribly useful to know that a value is a
346 %----------------------------------------------------------------------
347 \item[@DataConId@:] For the data constructors declared by a @data@
348 declaration. Their type is kept in {\em two} forms---as a regular
349 @Type@ (in the usual place), and also in its constituent pieces (in
350 the ``details''). We are frequently interested in those pieces.
352 %----------------------------------------------------------------------
353 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
354 the infinite family of tuples.
356 %----------------------------------------------------------------------
357 \item[@ImportedId@:] These are values defined outside this module.
358 {\em Everything} we want to know about them must be stored here (or in
361 %----------------------------------------------------------------------
362 \item[@PreludeId@:] ToDo
364 %----------------------------------------------------------------------
365 \item[@TopLevId@:] These are values defined at the top-level in this
366 module; i.e., those which {\em might} be exported (hence, a
367 @Name@). It does {\em not} include those which are moved to the
368 top-level through program transformations.
370 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
371 Theoretically, they could be floated inwards, but there's no known
372 advantage in doing so. This way, we can keep them with the same
373 @Unique@ throughout (no cloning), and, in general, we don't have to be
374 so paranoid about them.
376 In particular, we had the following problem generating an interface:
377 We have to ``stitch together'' info (1)~from the typechecker-produced
378 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
379 what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change}
380 between (1) and (2), you're sunk!
382 %----------------------------------------------------------------------
383 \item[@MethodSelId@:] A selector from a dictionary; it may select either
384 a method or a dictionary for one of the class's superclasses.
386 %----------------------------------------------------------------------
389 @mkDictFunId [a,b..] theta C T@ is the function derived from the
392 instance theta => C (T a b ..) where
395 It builds function @Id@ which maps dictionaries for theta,
396 to a dictionary for C (T a b ..).
398 *Note* that with the ``Mark Jones optimisation'', the theta may
399 include dictionaries for the immediate superclasses of C at the type
402 %----------------------------------------------------------------------
405 %----------------------------------------------------------------------
408 %----------------------------------------------------------------------
411 %----------------------------------------------------------------------
412 \item[@LocalId@:] A purely-local value, e.g., a function argument,
413 something defined in a @where@ clauses, ... --- but which appears in
414 the original program text.
416 %----------------------------------------------------------------------
417 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
418 the original program text; these are introduced by the compiler in
421 %----------------------------------------------------------------------
422 \item[@SpecPragmaId@:] Introduced by the compiler to record
423 Specialisation pragmas. It is dead code which MUST NOT be removed
424 before specialisation.
429 %----------------------------------------------------------------------
432 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
433 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
437 They have no free type variables, so if you are making a
438 type-variable substitution you don't need to look inside them.
440 They are constants, so they are not free variables. (When the STG
441 machine makes a closure, it puts all the free variables in the
442 closure; the above are not required.)
444 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
445 properties, but they may not.
448 %************************************************************************
450 \subsection[Id-general-funs]{General @Id@-related functions}
452 %************************************************************************
455 unsafeGenId2Id :: GenId ty -> Id
456 unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i
458 isDataCon id = is_data (unsafeGenId2Id id)
460 is_data (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = True
461 is_data (Id _ _ (TupleConId _ _) _ _) = True
462 is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec
463 is_data other = False
466 isTupleCon id = is_tuple (unsafeGenId2Id id)
468 is_tuple (Id _ _ (TupleConId _ _) _ _) = True
469 is_tuple (Id _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
470 is_tuple other = False
473 isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _)
474 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
475 Just (unspec, ty_maybes)
476 isSpecId_maybe other_id
479 isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _)
481 isSpecPragmaId_maybe other_id
486 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a
487 nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be
488 defined at top level (returns @True@). This is used to decide whether
489 the @Id@ is a candidate free variable. NB: you are only {\em sure}
490 about something if it returns @True@!
493 toplevelishId :: Id -> Bool
494 idHasNoFreeTyVars :: Id -> Bool
496 toplevelishId (Id _ _ details _ _)
499 chk (DataConId _ _ _ _ _ _ _ _) = True
500 chk (TupleConId _ _) = True
501 chk (RecordSelId _) = True
502 chk (ImportedId _) = True
503 chk (PreludeId _) = True
504 chk (TopLevId _) = True -- NB: see notes
505 chk (SuperDictSelId _ _) = True
506 chk (MethodSelId _ _) = True
507 chk (DefaultMethodId _ _ _) = True
508 chk (DictFunId _ _ _ _) = True
509 chk (ConstMethodId _ _ _ _ _) = True
510 chk (SpecId unspec _ _) = toplevelishId unspec
511 -- depends what the unspecialised thing is
512 chk (WorkerId unwrkr) = toplevelishId unwrkr
513 chk (InstId _ _) = False -- these are local
514 chk (LocalId _ _) = False
515 chk (SysLocalId _ _) = False
516 chk (SpecPragmaId _ _ _) = False
518 idHasNoFreeTyVars (Id _ _ details _ info)
521 chk (DataConId _ _ _ _ _ _ _ _) = True
522 chk (TupleConId _ _) = True
523 chk (RecordSelId _) = True
524 chk (ImportedId _) = True
525 chk (PreludeId _) = True
526 chk (TopLevId _) = True
527 chk (SuperDictSelId _ _) = True
528 chk (MethodSelId _ _) = True
529 chk (DefaultMethodId _ _ _) = True
530 chk (DictFunId _ _ _ _) = True
531 chk (ConstMethodId _ _ _ _ _) = True
532 chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
533 chk (InstId _ no_free_tvs) = no_free_tvs
534 chk (SpecId _ _ no_free_tvs) = no_free_tvs
535 chk (LocalId _ no_free_tvs) = no_free_tvs
536 chk (SysLocalId _ no_free_tvs) = no_free_tvs
537 chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
541 isTopLevId (Id _ _ (TopLevId _) _ _) = True
542 isTopLevId other = False
544 isImportedId (Id _ _ (ImportedId _) _ _) = True
545 isImportedId other = False
547 isBottomingId (Id _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
549 isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
550 isSysLocalId other = False
552 isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True
553 isSpecPragmaId other = False
555 isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True
556 isMethodSelId _ = False
558 isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True
559 isDefaultMethodId other = False
561 isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _)
562 = Just (cls, clsop, err)
563 isDefaultMethodId_maybe other = Nothing
565 isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True
566 isDictFunId other = False
568 isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True
569 isConstMethodId other = False
571 isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _)
572 = Just (cls, ty, clsop)
573 isConstMethodId_maybe other = Nothing
575 isSuperDictSelId_maybe (Id _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
576 isSuperDictSelId_maybe other_id = Nothing
578 isWorkerId (Id _ _ (WorkerId _) _ _) = True
579 isWorkerId other = False
582 isWrapperId id = workerExists (getIdStrictness id)
588 pprIdInUnfolding :: IdSet -> Id -> Pretty
590 pprIdInUnfolding in_scopes v
595 if v `elementOfUniqSet` in_scopes then
596 pprUnique (idUnique v)
598 -- ubiquitous Ids with special syntax:
599 else if v == nilDataCon then
601 else if isTupleCon v then
602 ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
604 -- ones to think about:
607 (Id _ _ v_details _ _) = v
610 -- these ones must have been exported by their original module
611 ImportedId _ -> pp_full_name
612 PreludeId _ -> pp_full_name
614 -- these ones' exportedness checked later...
615 TopLevId _ -> pp_full_name
616 DataConId _ _ _ _ _ _ _ _ -> pp_full_name
618 RecordSelId lbl -> ppr sty lbl
620 -- class-ish things: class already recorded as "mentioned"
622 -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
624 -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
625 DefaultMethodId c o _
626 -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
628 -- instance-ish things: should we try to figure out
629 -- *exactly* which extra instances have to be exported? (ToDo)
631 -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
632 ConstMethodId c t o _ _
633 -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
635 -- specialisations and workers
636 SpecId unspec ty_maybes _
638 pp = pprIdInUnfolding in_scopes unspec
640 ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
641 ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
646 pp = pprIdInUnfolding in_scopes unwrkr
648 ppBeside (ppPStr SLIT("_WRKR_ ")) pp
650 -- anything else? we're nae interested
651 other_id -> panic "pprIdInUnfolding:mystery Id"
653 ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
657 (m_str, n_str) = getOrigName v
660 if isAvarop n_str || isAconop n_str then
661 ppBesides [ppLparen, ppPStr n_str, ppRparen]
665 if isPreludeDefined v then
668 ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
670 pp_class :: Class -> Pretty
671 pp_class_op :: ClassOp -> Pretty
672 pp_type :: Type -> Pretty
673 pp_ty_maybe :: Maybe Type -> Pretty
675 pp_class clas = ppr ppr_Unfolding clas
676 pp_class_op op = ppr ppr_Unfolding op
678 pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
680 pp_ty_maybe Nothing = ppPStr SLIT("_N_")
681 pp_ty_maybe (Just t) = pp_type t
685 @whatsMentionedInId@ ferrets out the types/classes/instances on which
686 this @Id@ depends. If this Id is to appear in an interface, then
687 those entities had Jolly Well be in scope. Someone else up the
688 call-tree decides that.
693 :: IdSet -- Ids known to be in scope
694 -> Id -- Id being processed
695 -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
697 whatsMentionedInId in_scopes v
702 = getMentionedTyConsAndClassesFromType v_ty
704 result0 id_bag = (id_bag, tycons, clss)
707 = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
708 tcs `unionBags` tycons,
712 if v `elementOfUniqSet` in_scopes then
713 result0 emptyBag -- v not added to "mentioned"
715 -- ones to think about:
718 (Id _ _ v_details _ _) = v
721 -- specialisations and workers
722 SpecId unspec ty_maybes _
724 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
726 result1 ids2 tcs2 cs2
730 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
732 result1 ids2 tcs2 cs2
734 anything_else -> result0 (unitBag v) -- v is added to "mentioned"
738 Tell them who my wrapper function is.
741 myWrapperMaybe :: Id -> Maybe Id
743 myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
744 myWrapperMaybe other_id = Nothing
749 unfoldingUnfriendlyId -- return True iff it is definitely a bad
750 :: Id -- idea to export an unfolding that
751 -> Bool -- mentions this Id. Reason: it cannot
752 -- possibly be seen in another module.
754 unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
757 unfoldingUnfriendlyId id
758 | not (externallyVisibleId id) -- that settles that...
761 unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _)
762 = class_thing wrapper
764 -- "class thing": If we're going to use this worker Id in
765 -- an interface, we *have* to be able to untangle the wrapper's
766 -- strictness when reading it back in. At the moment, this
767 -- is not always possible: in precisely those cases where
768 -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
770 class_thing (Id _ _ (SuperDictSelId _ _) _ _) = True
771 class_thing (Id _ _ (MethodSelId _ _) _ _) = True
772 class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True
773 class_thing other = False
775 unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _)
776 -- a SPEC of a DictFunId can end up w/ gratuitous
777 -- TyVar(Templates) in the i/face; only a problem
778 -- if -fshow-pragma-name-errs; but we can do without the pain.
779 -- A HACK in any case (WDP 94/05/02)
780 = naughty_DictFunId dfun
782 unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
783 = naughty_DictFunId dfun -- similar deal...
785 unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
787 naughty_DictFunId :: IdDetails -> Bool
788 -- True <=> has a TyVar(Template) in the "type" part of its "name"
790 naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
791 naughty_DictFunId (DictFunId _ ty _ _)
792 = not (isGroundTy ty)
796 @externallyVisibleId@: is it true that another module might be
797 able to ``see'' this Id?
799 We need the @toplevelishId@ check as well as @isExported@ for when we
800 compile instance declarations in the prelude. @DictFunIds@ are
801 ``exported'' if either their class or tycon is exported, but, in
802 compiling the prelude, the compiler may not recognise that as true.
805 externallyVisibleId :: Id -> Bool
807 externallyVisibleId id@(Id _ _ details _ _)
808 = if isLocallyDefined id then
809 toplevelishId id && isExported id && not (weird_datacon details)
811 not (weird_tuplecon details)
812 -- if visible here, it must be visible elsewhere, too.
814 -- If it's a DataCon, it's not enough to know it (meaning
815 -- its TyCon) is exported; we need to know that it might
816 -- be visible outside. Consider:
818 -- data Foo a = Mumble | BigFoo a WeirdLocalType
820 -- We can't tell the outside world *anything* about Foo, because
821 -- of WeirdLocalType; but we need to know this when asked if
822 -- "Mumble" is externally visible...
825 weird_datacon (DataConId _ _ _ _ _ _ _ tycon)
826 = maybeToBool (maybePurelyLocalTyCon tycon)
828 weird_datacon not_a_datacon_therefore_not_weird = False
830 weird_tuplecon (TupleConId _ arity)
831 = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
832 weird_tuplecon _ = False
836 idWantsToBeINLINEd :: Id -> Bool
838 idWantsToBeINLINEd (Id _ _ _ IWantToBeINLINEd _) = True
839 idWantsToBeINLINEd _ = False
842 For @unlocaliseId@: See the brief commentary in
843 \tr{simplStg/SimplStg.lhs}.
847 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
849 unlocaliseId mod (Id u ty info (TopLevId fn))
850 = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
852 unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
853 = --false?: ASSERT(no_ftvs)
855 full_name = unlocaliseShortName mod u sn
857 Just (Id u ty info (TopLevId full_name))
859 unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
860 = --false?: on PreludeGlaST: ASSERT(no_ftvs)
862 full_name = unlocaliseShortName mod u sn
864 Just (Id u ty info (TopLevId full_name))
866 unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
867 = case unlocalise_parent mod u unspec of
869 Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))
871 unlocaliseId mod (Id u ty info (WorkerId unwrkr))
872 = case unlocalise_parent mod u unwrkr of
874 Just xx -> Just (Id u ty info (WorkerId xx))
876 unlocaliseId mod (Id u ty info (InstId name no_ftvs))
877 = Just (Id u ty info (TopLevId full_name))
878 -- type might be wrong, but it hardly matters
879 -- at this stage (just before printing C) ToDo
881 name = getLocalName name
882 full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
884 unlocaliseId mod other_id = Nothing
887 -- we have to be Very Careful for workers/specs of
890 unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs))
891 = --false?: ASSERT(no_ftvs)
893 full_name = unlocaliseShortName mod uniq sn
895 Just (Id uniq ty info (TopLevId full_name))
897 unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
898 = --false?: ASSERT(no_ftvs)
900 full_name = unlocaliseShortName mod uniq sn
902 Just (Id uniq ty info (TopLevId full_name))
904 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
905 -- we're OK otherwise
909 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
910 `Top-levelish Ids'' cannot have any free type variables, so applying
911 the type-env cannot have any effect. (NB: checked in CoreLint?)
913 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
914 former ``should be'' the usual crunch point.
917 type TypeEnv = TyVarEnv Type
919 applyTypeEnvToId :: TypeEnv -> Id -> Id
921 applyTypeEnvToId type_env id@(Id _ ty _ _ _)
922 | idHasNoFreeTyVars id
925 = apply_to_Id ( \ ty ->
926 applyTypeEnvToTy type_env ty
931 apply_to_Id :: (Type -> Type)
935 apply_to_Id ty_fn (Id u ty details prag info)
939 Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
941 apply_to_details (SpecId unspec ty_maybes no_ftvs)
943 new_unspec = apply_to_Id ty_fn unspec
944 new_maybes = map apply_to_maybe ty_maybes
946 SpecId new_unspec new_maybes (no_free_tvs ty)
947 -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
949 apply_to_maybe Nothing = Nothing
950 apply_to_maybe (Just ty) = Just (ty_fn ty)
952 apply_to_details (WorkerId unwrkr)
954 new_unwrkr = apply_to_Id ty_fn unwrkr
958 apply_to_details other = other
961 Sadly, I don't think the one using the magic typechecker substitution
962 can be done with @apply_to_Id@. Here we go....
964 Strictness is very important here. We can't leave behind thunks
965 with pointers to the substitution: it {\em must} be single-threaded.
969 applySubstToId :: Subst -> Id -> (Subst, Id)
971 applySubstToId subst id@(Id u ty info details)
972 -- *cannot* have a "idHasNoFreeTyVars" get-out clause
973 -- because, in the typechecker, we are still
974 -- *concocting* the types.
975 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
976 case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
977 case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
978 (s4, Id u new_ty new_info new_details) }}}
980 apply_to_details subst _ (InstId inst no_ftvs)
981 = case (applySubstToInst subst inst) of { (s2, new_inst) ->
982 (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
984 apply_to_details subst new_ty (SpecId unspec ty_maybes _)
985 = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
986 case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
987 (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
988 -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
990 apply_to_maybe subst Nothing = (subst, Nothing)
991 apply_to_maybe subst (Just ty)
992 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
995 apply_to_details subst _ (WorkerId unwrkr)
996 = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
997 (s2, WorkerId new_unwrkr) }
999 apply_to_details subst _ other = (subst, other)
1004 getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
1006 getIdNamePieces show_uniqs id
1007 = get (unsafeGenId2Id id)
1009 get (Id u _ details _ _)
1011 DataConId n _ _ _ _ _ _ _ ->
1012 case (nameOrigName n) of { (mod, name) ->
1013 if isPreludeDefinedName n then [name] else [mod, name] }
1015 TupleConId n _ -> [snd (nameOrigName n)]
1017 RecordSelId lbl -> panic "getIdNamePieces:RecordSelId"
1019 ImportedId n -> get_fullname_pieces n
1020 PreludeId n -> get_fullname_pieces n
1021 TopLevId n -> get_fullname_pieces n
1023 SuperDictSelId c sc ->
1024 case (getOrigName c) of { (c_mod, c_name) ->
1025 case (getOrigName sc) of { (sc_mod, sc_name) ->
1027 c_bits = if isPreludeDefined c
1029 else [c_mod, c_name]
1031 sc_bits= if isPreludeDefined sc
1033 else [sc_mod, sc_name]
1035 [SLIT("sdsel")] ++ c_bits ++ sc_bits }}
1037 MethodSelId clas op ->
1038 case (getOrigName clas) of { (c_mod, c_name) ->
1039 case (getClassOpString op) of { op_name ->
1040 if isPreludeDefined clas
1042 else [c_mod, c_name, op_name]
1045 DefaultMethodId clas op _ ->
1046 case (getOrigName clas) of { (c_mod, c_name) ->
1047 case (getClassOpString op) of { op_name ->
1048 if isPreludeDefined clas
1049 then [SLIT("defm"), op_name]
1050 else [SLIT("defm"), c_mod, c_name, op_name] }}
1052 DictFunId c ty _ _ ->
1053 case (getOrigName c) of { (c_mod, c_name) ->
1055 c_bits = if isPreludeDefined c
1057 else [c_mod, c_name]
1059 ty_bits = getTypeString ty
1061 [SLIT("dfun")] ++ c_bits ++ ty_bits }
1063 ConstMethodId c ty o _ _ ->
1064 case (getOrigName c) of { (c_mod, c_name) ->
1065 case (getTypeString ty) of { ty_bits ->
1066 case (getClassOpString o) of { o_name ->
1067 case (if isPreludeDefined c
1069 else [c_mod, c_name]) of { c_bits ->
1070 [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
1072 -- if the unspecialised equiv is "top-level",
1073 -- the name must be concocted from its name and the
1074 -- names of the types to which specialised...
1076 SpecId unspec ty_maybes _ ->
1077 get unspec ++ (if not (toplevelishId unspec)
1079 else concat (map typeMaybeString ty_maybes))
1082 get unwrkr ++ (if not (toplevelishId unwrkr)
1086 LocalId n _ -> let local = getLocalName n in
1087 if show_uniqs then [local, showUnique u] else [local]
1088 InstId n _ -> [getLocalName n, showUnique u]
1089 SysLocalId n _ -> [getLocalName n, showUnique u]
1090 SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
1092 get_fullname_pieces :: Name -> [FAST_STRING]
1093 get_fullname_pieces n
1094 = BIND (nameOrigName n) _TO_ (mod, name) ->
1095 if isPreludeDefinedName n
1101 %************************************************************************
1103 \subsection[Id-type-funs]{Type-related @Id@ functions}
1105 %************************************************************************
1108 idType :: GenId ty -> ty
1110 idType (Id _ ty _ _ _) = ty
1115 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1117 getMentionedTyConsAndClassesFromId id
1118 = getMentionedTyConsAndClassesFromType (idType id)
1123 idPrimRep i = typePrimRep (idType i)
1128 getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
1129 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
1130 getInstIdModule other = panic "Id:getInstIdModule"
1134 %************************************************************************
1136 \subsection[Id-overloading]{Functions related to overloading}
1138 %************************************************************************
1141 mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
1142 mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
1143 mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
1145 mkDictFunId u c ity full_ty from_here mod info
1146 = Id u full_ty (DictFunId c ity from_here mod) NoPragmaInfo info
1148 mkConstMethodId u c op ity full_ty from_here mod info
1149 = Id u full_ty (ConstMethodId c ity op from_here mod) NoPragmaInfo info
1151 mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
1153 mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo
1156 getConstMethodId clas op ty
1157 = -- constant-method info is hidden in the IdInfo of
1158 -- the class-op id (as mentioned up above).
1160 sel_id = getMethodSelId clas op
1162 case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1164 Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
1165 ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1166 ppr PprDebug sel_id],
1167 ppStr "(This can arise if an interface pragma refers to an instance",
1168 ppStr "but there is no imported interface which *defines* that instance.",
1169 ppStr "The info above, however ugly, should indicate what else you need to import."
1174 %************************************************************************
1176 \subsection[local-funs]{@LocalId@-related functions}
1178 %************************************************************************
1181 mkImported n ty info = Id (nameUnique n) ty (ImportedId n) NoPragmaInfo info
1182 mkPreludeId n ty info = Id (nameUnique n) ty (PreludeId n) NoPragmaInfo info
1185 updateIdType :: Id -> Type -> Id
1186 updateIdType (Id u _ info details) ty = Id u ty info details
1191 type MyTy a b = GenType (GenTyVar a) b
1192 type MyId a b = GenId (MyTy a b)
1194 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1196 -- SysLocal: for an Id being created by the compiler out of thin air...
1197 -- UserLocal: an Id with a name the user might recognize...
1198 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1200 mkSysLocal str uniq ty loc
1201 = Id uniq ty (SysLocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1203 mkUserLocal str uniq ty loc
1204 = Id uniq ty (LocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1206 -- mkUserId builds a local or top-level Id, depending on the name given
1207 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1208 mkUserId name ty pragma_info
1210 = Id (nameUnique name) ty (LocalId name (no_free_tvs ty)) pragma_info noIdInfo
1212 = Id (nameUnique name) ty
1213 (if isLocallyDefinedName name then TopLevId name else ImportedId name)
1214 pragma_info noIdInfo
1221 -- for a SpecPragmaId being created by the compiler out of thin air...
1222 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1223 mkSpecPragmaId str uniq ty specid loc
1224 = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
1227 mkSpecId u unspec ty_maybes ty info
1228 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1229 Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1231 -- Specialised version of constructor: only used in STG and code generation
1232 -- Note: The specialsied Id has the same unique as the unspeced Id
1234 mkSameSpecCon ty_maybes unspec@(Id u ty info details)
1235 = ASSERT(isDataCon unspec)
1236 ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1237 Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1239 new_ty = specialiseTy ty ty_maybes 0
1241 localiseId :: Id -> Id
1242 localiseId id@(Id u ty info details)
1243 = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
1245 name = getOccName id
1249 mkIdWithNewUniq :: Id -> Unique -> Id
1251 mkIdWithNewUniq (Id _ ty details prag info) uniq
1252 = Id uniq ty details prag info
1255 Make some local @Ids@ for a template @CoreExpr@. These have bogus
1256 @Uniques@, but that's OK because the templates are supposed to be
1257 instantiated before use.
1259 mkTemplateLocals :: [Type] -> [Id]
1260 mkTemplateLocals tys
1261 = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1262 (getBuiltinUniques (length tys))
1267 getIdInfo :: GenId ty -> IdInfo
1268 getPragmaInfo :: GenId ty -> PragmaInfo
1270 getIdInfo (Id _ _ _ _ info) = info
1271 getPragmaInfo (Id _ _ _ info _) = info
1274 replaceIdInfo :: Id -> IdInfo -> Id
1276 replaceIdInfo (Id u ty _ details) info = Id u ty info details
1278 selectIdInfoForSpecId :: Id -> IdInfo
1279 selectIdInfoForSpecId unspec
1280 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1281 noIdInfo `addInfo_UF` getIdUnfolding unspec
1285 %************************************************************************
1287 \subsection[Id-arities]{Arity-related functions}
1289 %************************************************************************
1291 For locally-defined Ids, the code generator maintains its own notion
1292 of their arities; so it should not be asking... (but other things
1293 besides the code-generator need arity info!)
1296 getIdArity :: Id -> ArityInfo
1297 getIdArity (Id _ _ _ _ id_info) = getInfo id_info
1299 dataConArity :: DataCon -> Int
1300 dataConArity id@(Id _ _ _ _ id_info)
1301 = ASSERT(isDataCon id)
1302 case (arityMaybe (getInfo id_info)) of
1303 Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1306 addIdArity :: Id -> Int -> Id
1307 addIdArity (Id u ty details pinfo info) arity
1308 = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
1311 %************************************************************************
1313 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1315 %************************************************************************
1319 -> [StrictnessMark] -> [FieldLabel]
1320 -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1323 -- can get the tag and all the pieces of the type from the Type
1325 mkDataCon n stricts fields tvs ctxt args_tys tycon
1326 = ASSERT(length stricts == length args_tys)
1329 -- NB: data_con self-recursion; should be OK as tags are not
1330 -- looked at until late in the game.
1334 (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon)
1338 data_con_tag = position_within fIRST_TAG data_con_family
1340 data_con_family = tyConDataCons tycon
1342 position_within :: Int -> [Id] -> Int
1344 position_within acc (c:cs)
1345 = if c == data_con then acc else position_within (acc+1) cs
1347 position_within acc []
1348 = panic "mkDataCon: con not found in family"
1352 = mkSigmaTy tvs ctxt
1353 (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1355 datacon_info = noIdInfo `addInfo_UF` unfolding
1356 `addInfo` mkArityInfo arity
1357 --ToDo: `addInfo` specenv
1359 arity = length args_tys
1366 -- else -- do some business...
1368 (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1369 tyvar_tys = mkTyVarTys tyvars
1371 BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1373 mkUnfolding EssentialUnfolding -- for data constructors
1374 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1377 mk_uf_bits tvs ctxt arg_tys tycon
1379 (inst_env, tyvars, tyvar_tys)
1380 = instantiateTyVarTemplates tvs
1383 -- the "context" and "arg_tys" have TyVarTemplates in them, so
1384 -- we instantiate those types to have the right TyVars in them
1386 BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1387 _TO_ inst_dict_tys ->
1388 BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys ->
1390 -- We can only have **ONE** call to mkTemplateLocals here;
1391 -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1392 -- (Mega-Sigh) [ToDo]
1393 BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
1395 BIND (splitAt (length ctxt) all_vars) _TO_ (dict_vars, vars) ->
1397 (tyvars, dict_vars, vars)
1400 -- these are really dubious Types, but they are only to make the
1401 -- binders for the lambdas for tossed-away dicts.
1402 ctxt_ty (clas, ty) = mkDictTy clas ty
1407 mkTupleCon :: Arity -> Id
1410 = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info
1412 n = mkTupleDataConName arity
1414 ty = mkSigmaTy tyvars []
1415 (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1416 tycon = mkTupleTyCon arity
1417 tyvars = take arity alphaTyVars
1418 tyvar_tys = mkTyVarTys tyvars
1421 = noIdInfo `addInfo_UF` unfolding
1422 `addInfo` mkArityInfo arity
1423 --LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1430 -- else -- do some business...
1432 (tyvars, dict_vars, vars) = mk_uf_bits arity
1433 tyvar_tys = mkTyVarTys tyvars
1435 BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1438 EssentialUnfolding -- data constructors
1439 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1443 = BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
1447 tyvar_tmpls = take arity alphaTyVars
1448 (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
1452 fIRST_TAG = 1 -- Tags allocated from here for real constructors
1456 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1457 dataConTag (Id _ _ (DataConId _ tag _ _ _ _ _ _) _ _) = tag
1458 dataConTag (Id _ _ (TupleConId _ _) _ _) = fIRST_TAG
1459 dataConTag (Id _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
1461 dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
1462 dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon
1463 dataConTyCon (Id _ _ (TupleConId _ a) _ _) = mkTupleTyCon a
1465 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1466 -- will panic if not a DataCon
1468 dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1469 = (tyvars, theta_ty, arg_tys, tycon)
1471 dataConSig (Id _ _ (TupleConId _ arity) _ _)
1472 = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1474 tyvars = take arity alphaTyVars
1475 tyvar_tys = mkTyVarTys tyvars
1477 dataConFieldLabels :: DataCon -> [FieldLabel]
1478 dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields
1479 dataConFieldLabels (Id _ _ (TupleConId _ _) _ _) = []
1481 dataConStrictMarks :: DataCon -> [StrictnessMark]
1482 dataConStrictMarks (Id _ _ (DataConId _ _ stricts _ _ _ _ _) _ _) = stricts
1483 dataConStrictMarks (Id _ _ (TupleConId _ arity) _ _)
1484 = take arity (repeat NotMarkedStrict)
1486 dataConArgTys :: DataCon
1487 -> [Type] -- Instantiated at these types
1488 -> [Type] -- Needs arguments of these types
1489 dataConArgTys con_id inst_tys
1490 = map (instantiateTy tenv) arg_tys
1492 (tyvars, _, arg_tys, _) = dataConSig con_id
1493 tenv = tyvars `zipEqual` inst_tys
1497 mkRecordSelId field_label selector_ty
1498 = Id (nameUnique name)
1500 (RecordSelId field_label)
1504 name = fieldLabelName field_label
1506 recordSelectorFieldLabel :: Id -> FieldLabel
1507 recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl
1511 Data type declarations are of the form:
1513 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1515 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1516 @C1 x y z@, we want a function binding:
1518 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1520 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1521 2nd-order polymorphic lambda calculus with explicit types.
1523 %************************************************************************
1525 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1527 %************************************************************************
1529 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1530 and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
1531 @TyVars@ don't really have to be new, because we are only producing a
1534 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1537 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1538 EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the
1539 example above: a, b, and x, y, z], which is enough (in the important
1540 \tr{DsExpr} case). (The middle set of @Ids@ is binders for any
1541 dictionaries, in the even of an overloaded data-constructor---none at
1545 getIdUnfolding :: Id -> UnfoldingDetails
1547 getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info
1550 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1551 addIdUnfolding id@(Id u ty info details) unfold_details
1553 case (isLocallyDefined id, unfold_details) of
1554 (_, NoUnfoldingDetails) -> True
1555 (True, IWantToBeINLINEd _) -> True
1556 (False, IWantToBeINLINEd _) -> False -- v bad
1560 Id u ty (info `addInfo_UF` unfold_details) details
1564 In generating selector functions (take a dictionary, give back one
1565 component...), we need to what out for the nothing-to-select cases (in
1566 which case the ``selector'' is just an identity function):
1568 class Eq a => Foo a { } # the superdict selector for "Eq"
1570 class Foo a { op :: Complex b => c -> b -> a }
1571 # the method selector for "op";
1572 # note local polymorphism...
1575 %************************************************************************
1577 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1579 %************************************************************************
1582 getIdDemandInfo :: Id -> DemandInfo
1583 getIdDemandInfo (Id _ _ _ _ info) = getInfo info
1585 addIdDemandInfo :: Id -> DemandInfo -> Id
1586 addIdDemandInfo (Id u ty details prags info) demand_info
1587 = Id u ty details prags (info `addInfo` demand_info)
1591 getIdUpdateInfo :: Id -> UpdateInfo
1592 getIdUpdateInfo (Id _ _ _ _ info) = getInfo info
1594 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1595 addIdUpdateInfo (Id u ty details prags info) upd_info
1596 = Id u ty details prags (info `addInfo` upd_info)
1601 getIdArgUsageInfo :: Id -> ArgUsageInfo
1602 getIdArgUsageInfo (Id u ty info details) = getInfo info
1604 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1605 addIdArgUsageInfo (Id u ty info details) au_info
1606 = Id u ty (info `addInfo` au_info) details
1612 getIdFBTypeInfo :: Id -> FBTypeInfo
1613 getIdFBTypeInfo (Id u ty info details) = getInfo info
1615 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1616 addIdFBTypeInfo (Id u ty info details) upd_info
1617 = Id u ty (info `addInfo` upd_info) details
1623 getIdSpecialisation :: Id -> SpecEnv
1624 getIdSpecialisation (Id _ _ _ _ info) = getInfo info
1626 addIdSpecialisation :: Id -> SpecEnv -> Id
1627 addIdSpecialisation (Id u ty details prags info) spec_info
1628 = Id u ty details prags (info `addInfo` spec_info)
1632 Strictness: we snaffle the info out of the IdInfo.
1635 getIdStrictness :: Id -> StrictnessInfo
1637 getIdStrictness (Id _ _ _ _ info) = getInfo info
1639 addIdStrictness :: Id -> StrictnessInfo -> Id
1641 addIdStrictness (Id u ty details prags info) strict_info
1642 = Id u ty details prags (info `addInfo` strict_info)
1645 %************************************************************************
1647 \subsection[Id-comparison]{Comparison functions for @Id@s}
1649 %************************************************************************
1651 Comparison: equality and ordering---this stuff gets {\em hammered}.
1654 cmpId (Id u1 _ _ _ _) (Id u2 _ _ _ _) = cmp u1 u2
1655 -- short and very sweet
1659 instance Ord3 (GenId ty) where
1662 instance Eq (GenId ty) where
1663 a == b = case cmpId a b of { EQ_ -> True; _ -> False }
1664 a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
1666 instance Ord (GenId ty) where
1667 a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
1668 a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
1669 a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
1670 a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
1671 _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1674 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1675 account when comparing two data constructors. We need to do this
1676 because a specialised data constructor has the same Unique as its
1677 unspecialised counterpart.
1680 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1682 cmpId_withSpecDataCon id1 id2
1683 | eq_ids && isDataCon id1 && isDataCon id2
1684 = cmpEqDataCon id1 id2
1689 cmp_ids = cmpId id1 id2
1690 eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
1692 cmpEqDataCon (Id _ _ (SpecId _ mtys1 _) _ _) (Id _ _ (SpecId _ mtys2 _) _ _)
1693 = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1695 cmpEqDataCon _ (Id _ _ (SpecId _ _ _) _ _) = LT_
1696 cmpEqDataCon (Id _ _ (SpecId _ _ _) _ _) _ = GT_
1697 cmpEqDataCon _ _ = EQ_
1700 %************************************************************************
1702 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1704 %************************************************************************
1707 instance Outputable ty => Outputable (GenId ty) where
1708 ppr sty id = pprId sty id
1710 -- and a SPECIALIZEd one:
1711 instance Outputable {-Id, i.e.:-}(GenId Type) where
1712 ppr sty id = pprId sty id
1714 showId :: PprStyle -> Id -> String
1715 showId sty id = ppShow 80 (pprId sty id)
1718 -- for DictFuns (instances) and const methods (instance code bits we
1719 -- can call directly): exported (a) if *either* the class or
1720 -- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
1721 -- class and tycon are from PreludeCore [non-std, but convenient]
1722 -- *and* the thing was defined in this module.
1724 instance_export_flag :: Class -> Type -> Bool -> ExportFlag
1726 instance_export_flag clas inst_ty from_here
1727 = panic "Id:instance_export_flag"
1729 = if instanceIsExported clas inst_ty from_here
1735 Default printing code (not used for interfaces):
1737 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1741 pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
1745 pieces_to_print -- maybe use Unique only
1746 = if isSysLocalId id then tail pieces else pieces
1748 ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
1752 PprForAsm _ _ -> for_code
1753 PprInterface -> ppr other_sty occur_name
1754 PprForUser -> ppr other_sty occur_name
1755 PprUnfolding -> qualified_name pieces
1756 PprDebug -> qualified_name pieces
1757 PprShowAll -> ppBesides [qualified_name pieces,
1760 ppr other_sty (idType id),
1761 ppIdInfo other_sty (unsafeGenId2Id id) True
1762 (\x->x) nullIdEnv (getIdInfo id),
1763 ppPStr SLIT("-}") ])]
1765 occur_name = getOccName id `appendRdr`
1766 (if not (isSysLocalId id)
1768 else SLIT(".") _APPEND_ (showUnique (idUnique id)))
1770 qualified_name pieces
1771 = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
1773 pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add
1774 pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = ppNil
1775 pp_uniq (Id _ _ (TupleConId _ _) _ _) = ppNil
1776 pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere
1777 pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil
1778 pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil
1779 pp_uniq (Id _ _ (InstId _ _) _ _) = ppNil
1780 pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (idUnique other_id), ppPStr SLIT("-}")]
1782 -- print PprDebug Ids with # afterwards if they are of primitive type.
1783 pp_ubxd pretty = pretty
1785 {- LATER: applying isPrimType restricts type
1786 pp_ubxd pretty = if isPrimType (idType id)
1787 then ppBeside pretty (ppChar '#')
1794 idUnique (Id u _ _ _ _) = u
1796 instance Uniquable (GenId ty) where
1799 instance NamedThing (GenId ty) where
1800 getName this_id@(Id u _ details _ _)
1803 get (LocalId n _) = n
1804 get (SysLocalId n _) = n
1805 get (SpecPragmaId n _ _)= n
1806 get (ImportedId n) = n
1807 get (PreludeId n) = n
1808 get (TopLevId n) = n
1809 get (InstId n _) = n
1810 get (DataConId n _ _ _ _ _ _ _) = n
1811 get (TupleConId n _) = n
1812 get (RecordSelId l) = getName l
1813 -- get _ = pprPanic "Id.Id.NamedThing.getName:" (pprId PprDebug this_id)
1816 get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ???
1817 (mod, _) -> (mod, getClassOpString op)
1819 get (SpecId unspec ty_maybes _)
1820 = BIND getOrigName unspec _TO_ (mod, unspec_nm) ->
1821 BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
1824 (if not (toplevelishId unspec)
1830 get (WorkerId unwrkr)
1831 = BIND getOrigName unwrkr _TO_ (mod, unwrkr_nm) ->
1834 (if not (toplevelishId unwrkr)
1841 -- the remaining internally-generated flavours of
1842 -- Ids really do not have meaningful "original name" stuff,
1843 -- but we need to make up something (usually for debugging output)
1845 = BIND (getIdNamePieces True this_id) _TO_ (piece1:pieces) ->
1846 BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
1847 (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
1852 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1853 the @Uniques@ out of local @Ids@ given to it.
1855 %************************************************************************
1857 \subsection{@IdEnv@s and @IdSet@s}
1859 %************************************************************************
1862 type IdEnv elt = UniqFM elt
1864 nullIdEnv :: IdEnv a
1866 mkIdEnv :: [(GenId ty, a)] -> IdEnv a
1867 unitIdEnv :: GenId ty -> a -> IdEnv a
1868 addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
1869 growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
1870 growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1872 delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
1873 delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
1874 combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1875 mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
1876 modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
1877 rngIdEnv :: IdEnv a -> [a]
1879 isNullIdEnv :: IdEnv a -> Bool
1880 lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
1881 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1885 addOneToIdEnv = addToUFM
1886 combineIdEnvs = plusUFM_C
1887 delManyFromIdEnv = delListFromUFM
1888 delOneFromIdEnv = delFromUFM
1890 lookupIdEnv = lookupUFM
1893 nullIdEnv = emptyUFM
1897 growIdEnvList env pairs = plusUFM env (listToUFM pairs)
1898 isNullIdEnv env = sizeUFM env == 0
1899 lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
1901 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1902 -- modify function, and put it back.
1904 modifyIdEnv env mangle_fn key
1905 = case (lookupIdEnv env key) of
1907 Just xx -> addOneToIdEnv env key (mangle_fn xx)
1911 type GenIdSet ty = UniqSet (GenId ty)
1912 type IdSet = UniqSet (GenId Type)
1914 emptyIdSet :: GenIdSet ty
1915 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1916 unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1917 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1918 idSetToList :: GenIdSet ty -> [GenId ty]
1919 unitIdSet :: GenId ty -> GenIdSet ty
1920 addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
1921 elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
1922 minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1923 isEmptyIdSet :: GenIdSet ty -> Bool
1924 mkIdSet :: [GenId ty] -> GenIdSet ty
1926 emptyIdSet = emptyUniqSet
1927 unitIdSet = unitUniqSet
1928 addOneToIdSet = addOneToUniqSet
1929 intersectIdSets = intersectUniqSets
1930 unionIdSets = unionUniqSets
1931 unionManyIdSets = unionManyUniqSets
1932 idSetToList = uniqSetToList
1933 elementOfIdSet = elementOfUniqSet
1934 minusIdSet = minusUniqSet
1935 isEmptyIdSet = isEmptyUniqSet