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 getIdPrimRep, getInstIdModule,
36 getMentionedTyConsAndClassesFromId,
38 getDataConSig, getInstantiatedDataConSig,
43 isDataCon, isTupleCon,
44 isSpecId_maybe, isSpecPragmaId_maybe,
45 toplevelishId, externallyVisibleId,
46 isTopLevId, isWorkerId, isWrapperId,
47 isImportedId, isSysLocalId,
49 isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
52 isConstMethodId_maybe,
53 cmpId_withSpecDataCon,
56 unfoldingUnfriendlyId, -- ToDo: rm, eventually
58 -- dataConMentionsNonPreludeTyCon,
61 applySubstToId, applyTypeEnvToId,
62 -- not exported: apply_to_Id, -- please don't use this, generally
64 -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
65 getIdArity, getDataConArity, addIdArity,
66 getIdDemandInfo, addIdDemandInfo,
67 getIdSpecialisation, addIdSpecialisation,
68 getIdStrictness, addIdStrictness,
69 getIdUnfolding, addIdUnfolding,
70 getIdUpdateInfo, addIdUpdateInfo,
71 getIdArgUsageInfo, addIdArgUsageInfo,
72 getIdFBTypeInfo, addIdFBTypeInfo,
73 -- don't export the types, lest OptIdInfo be dragged in!
81 -- "Environments" keyed off of Ids, and sets of Ids
83 lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
84 growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
85 delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
88 -- and to make the interface self-sufficient...
89 GenIdSet(..), IdSet(..)
93 import IdLoop -- for paranoia checking
94 import TyLoop -- for paranoia checking
95 import NameLoop -- for paranoia checking
98 import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
100 import Maybes ( maybeToBool )
101 import NameTypes ( mkShortName, fromPrelude, FullName, ShortName )
102 import Name ( Name(..) )
103 import Outputable ( isAvarop, isAconop, getLocalName,
104 isExported, ExportFlag(..) )
105 import PragmaInfo ( PragmaInfo(..) )
106 import PrelMods ( pRELUDE_BUILTIN )
107 import PprType ( GenType, GenTyVar,
108 getTypeString, typeMaybeString, specMaybeTysSuffix )
111 import SrcLoc ( mkBuiltinSrcLoc )
112 import TyCon ( TyCon, mkTupleTyCon, getTyConDataCons )
113 import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
114 applyTyCon, isPrimType, instantiateTy,
116 GenType, ThetaType(..), TauType(..), Type(..)
118 import TyVar ( GenTyVar, alphaTyVars, isEmptyTyVarSet )
120 import UniqSet -- practically all of it
121 import Unique ( Unique, mkTupleDataConUnique, pprUnique, showUnique )
122 import Util ( mapAccumL, nOfThem, panic, pprPanic, assertPanic )
125 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
128 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
129 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
130 strictness). The essential info about different kinds of @Ids@ is
133 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
137 Unique -- Key for fast comparison
138 ty -- Id's type; used all the time;
139 IdDetails -- Stuff about individual kinds of Ids.
140 PragmaInfo -- Properties of this Id requested by programmer
141 -- eg specialise-me, inline-me
142 IdInfo -- Properties of this Id deduced by compiler
146 data StrictnessMark = MarkedStrict | NotMarkedStrict
150 ---------------- Local values
152 = LocalId ShortName -- mentioned by the user
153 Bool -- True <=> no free type vars
155 | SysLocalId ShortName -- made up by the compiler
156 Bool -- as for LocalId
158 | SpecPragmaId ShortName -- introduced by the compiler
159 (Maybe Id) -- for explicit specid in pragma
160 Bool -- as for LocalId
162 ---------------- Global values
164 | ImportedId FullName -- Id imported from an interface
166 | PreludeId FullName -- things < Prelude that compiler "knows" about
168 | TopLevId FullName -- Top-level in the orig source pgm
169 -- (not moved there by transformations).
171 -- a TopLevId's type may contain free type variables, if
172 -- the monomorphism restriction applies.
174 ---------------- Data constructors
178 [StrictnessMark] -- Strict args; length = arity
180 [TyVar] [(Class,Type)] [Type] TyCon
182 -- forall tyvars . theta_ty =>
183 -- unitype_1 -> ... -> unitype_n -> tycon tyvars
185 | TupleConId Int -- Its arity
187 ---------------- Things to do with overloading
189 | SuperDictSelId -- Selector for superclass dictionary
190 Class -- The class (input dict)
191 Class -- The superclass (result dict)
193 | MethodSelId Class -- An overloaded class operation, with
194 -- a fully polymorphic type. Its code
195 -- just selects a method from the
196 -- dictionary. The class.
197 ClassOp -- The operation
199 -- NB: The IdInfo for a MethodSelId has all the info about its
200 -- related "constant method Ids", which are just
201 -- specialisations of this general one.
203 | DefaultMethodId -- Default method for a particular class op
204 Class -- same class, <blah-blah> info as MethodSelId
205 ClassOp -- (surprise, surprise)
206 Bool -- True <=> I *know* this default method Id
207 -- is a generated one that just says
208 -- `error "No default method for <op>"'.
211 | DictFunId Class -- A DictFun is uniquely identified
212 Type -- by its class and type; this type has free type vars,
213 -- whose identity is irrelevant. Eg Class = Eq
215 -- The "a" is irrelevant. As it is too painful to
216 -- actually do comparisons that way, we kindly supply
217 -- a Unique for that purpose.
218 Bool -- True <=> from an instance decl in this mod
219 FAST_STRING -- module where instance came from
222 | ConstMethodId -- A method which depends only on the type of the
223 -- instance, and not on any further dictionaries etc.
224 Class -- Uniquely identified by:
225 Type -- (class, type, classop) triple
227 Bool -- True <=> from an instance decl in this mod
228 FAST_STRING -- module where instance came from
230 | InstId ShortName -- An instance of a dictionary, class operation,
231 -- or overloaded value
233 | SpecId -- A specialisation of another Id
234 Id -- Id of which this is a specialisation
235 [Maybe Type] -- Types at which it is specialised;
236 -- A "Nothing" says this type ain't relevant.
237 Bool -- True <=> no free type vars; it's not enough
238 -- to know about the unspec version, because
239 -- we may specialise to a type w/ free tyvars
240 -- (i.e., in one of the "Maybe Type" dudes).
242 | WorkerId -- A "worker" for some other Id
243 Id -- Id for which this is a worker
253 DictFunIds are generated from instance decls.
258 instance Foo a => Foo [a] where
261 generates the dict fun id decl
263 dfun.Foo.[*] = \d -> ...
265 The dfun id is uniquely named by the (class, type) pair. Notice, it
266 isn't a (class,tycon) pair any more, because we may get manually or
267 automatically generated specialisations of the instance decl:
269 instance Foo [Int] where
276 The type variables in the name are irrelevant; we print them as stars.
279 Constant method ids are generated from instance decls where
280 there is no context; that is, no dictionaries are needed to
281 construct the method. Example
283 instance Foo Int where
286 Then we get a constant method
291 It is possible, albeit unusual, to have a constant method
292 for an instance decl which has type vars:
294 instance Foo [a] where
298 We get the constant method
302 So a constant method is identified by a class/op/type triple.
303 The type variables in the type are irrelevant.
306 For Ids whose names must be known/deducible in other modules, we have
307 to conjure up their worker's names (and their worker's worker's
308 names... etc) in a known systematic way.
311 %************************************************************************
313 \subsection[Id-documentation]{Documentation}
315 %************************************************************************
319 The @Id@ datatype describes {\em values}. The basic things we want to
320 know: (1)~a value's {\em type} (@idType@ is a very common
321 operation in the compiler); and (2)~what ``flavour'' of value it might
322 be---for example, it can be terribly useful to know that a value is a
326 %----------------------------------------------------------------------
327 \item[@DataConId@:] For the data constructors declared by a @data@
328 declaration. Their type is kept in {\em two} forms---as a regular
329 @Type@ (in the usual place), and also in its constituent pieces (in
330 the ``details''). We are frequently interested in those pieces.
332 %----------------------------------------------------------------------
333 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
334 the infinite family of tuples.
336 %----------------------------------------------------------------------
337 \item[@ImportedId@:] These are values defined outside this module.
338 {\em Everything} we want to know about them must be stored here (or in
341 %----------------------------------------------------------------------
342 \item[@PreludeId@:] ToDo
344 %----------------------------------------------------------------------
345 \item[@TopLevId@:] These are values defined at the top-level in this
346 module; i.e., those which {\em might} be exported (hence, a
347 @FullName@). It does {\em not} include those which are moved to the
348 top-level through program transformations.
350 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
351 Theoretically, they could be floated inwards, but there's no known
352 advantage in doing so. This way, we can keep them with the same
353 @Unique@ throughout (no cloning), and, in general, we don't have to be
354 so paranoid about them.
356 In particular, we had the following problem generating an interface:
357 We have to ``stitch together'' info (1)~from the typechecker-produced
358 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
359 what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change}
360 between (1) and (2), you're sunk!
362 %----------------------------------------------------------------------
363 \item[@MethodSelId@:] A selector from a dictionary; it may select either
364 a method or a dictionary for one of the class's superclasses.
366 %----------------------------------------------------------------------
369 @mkDictFunId [a,b..] theta C T@ is the function derived from the
372 instance theta => C (T a b ..) where
375 It builds function @Id@ which maps dictionaries for theta,
376 to a dictionary for C (T a b ..).
378 *Note* that with the ``Mark Jones optimisation'', the theta may
379 include dictionaries for the immediate superclasses of C at the type
382 %----------------------------------------------------------------------
385 %----------------------------------------------------------------------
388 %----------------------------------------------------------------------
391 %----------------------------------------------------------------------
392 \item[@LocalId@:] A purely-local value, e.g., a function argument,
393 something defined in a @where@ clauses, ... --- but which appears in
394 the original program text.
396 %----------------------------------------------------------------------
397 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
398 the original program text; these are introduced by the compiler in
401 %----------------------------------------------------------------------
402 \item[@SpecPragmaId@:] Introduced by the compiler to record
403 Specialisation pragmas. It is dead code which MUST NOT be removed
404 before specialisation.
409 %----------------------------------------------------------------------
412 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
413 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
417 They have no free type variables, so if you are making a
418 type-variable substitution you don't need to look inside them.
420 They are constants, so they are not free variables. (When the STG
421 machine makes a closure, it puts all the free variables in the
422 closure; the above are not required.)
424 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
425 properties, but they may not.
428 %************************************************************************
430 \subsection[Id-general-funs]{General @Id@-related functions}
432 %************************************************************************
435 unsafeGenId2Id :: GenId ty -> Id
436 unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i
438 isDataCon id = is_data (unsafeGenId2Id id)
440 is_data (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
441 is_data (Id _ _ (TupleConId _) _ _) = True
442 is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec
443 is_data other = False
446 isTupleCon id = is_tuple (unsafeGenId2Id id)
448 is_tuple (Id _ _ (TupleConId _) _ _) = True
449 is_tuple (Id _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
450 is_tuple other = False
453 isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _)
454 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
455 Just (unspec, ty_maybes)
456 isSpecId_maybe other_id
459 isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _)
461 isSpecPragmaId_maybe other_id
466 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a
467 nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be
468 defined at top level (returns @True@). This is used to decide whether
469 the @Id@ is a candidate free variable. NB: you are only {\em sure}
470 about something if it returns @True@!
473 toplevelishId :: Id -> Bool
474 idHasNoFreeTyVars :: Id -> Bool
476 toplevelishId (Id _ _ details _ _)
479 chk (DataConId _ _ _ _ _ _ _) = True
480 chk (TupleConId _) = True
481 chk (ImportedId _) = True
482 chk (PreludeId _) = True
483 chk (TopLevId _) = True -- NB: see notes
484 chk (SuperDictSelId _ _) = True
485 chk (MethodSelId _ _) = True
486 chk (DefaultMethodId _ _ _) = True
487 chk (DictFunId _ _ _ _) = True
488 chk (ConstMethodId _ _ _ _ _) = True
489 chk (SpecId unspec _ _) = toplevelishId unspec
490 -- depends what the unspecialised thing is
491 chk (WorkerId unwrkr) = toplevelishId unwrkr
492 chk (InstId _) = False -- these are local
493 chk (LocalId _ _) = False
494 chk (SysLocalId _ _) = False
495 chk (SpecPragmaId _ _ _) = False
497 idHasNoFreeTyVars (Id _ _ details _ info)
500 chk (DataConId _ _ _ _ _ _ _) = True
501 chk (TupleConId _) = True
502 chk (ImportedId _) = True
503 chk (PreludeId _) = True
504 chk (TopLevId _) = True
505 chk (SuperDictSelId _ _) = True
506 chk (MethodSelId _ _) = True
507 chk (DefaultMethodId _ _ _) = True
508 chk (DictFunId _ _ _ _) = True
509 chk (ConstMethodId _ _ _ _ _) = True
510 chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
511 chk (InstId _) = False -- these are local
512 chk (SpecId _ _ no_free_tvs) = no_free_tvs
513 chk (LocalId _ no_free_tvs) = no_free_tvs
514 chk (SysLocalId _ no_free_tvs) = no_free_tvs
515 chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
519 isTopLevId (Id _ _ (TopLevId _) _ _) = True
520 isTopLevId other = False
522 isImportedId (Id _ _ (ImportedId _) _ _) = True
523 isImportedId other = False
525 isBottomingId (Id _ _ _ _ info) = panic "isBottomingId not implemented"
526 -- LATER: bottomIsGuaranteed (getInfo info)
528 isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
529 isSysLocalId other = False
531 isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True
532 isSpecPragmaId other = False
534 isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True
535 isMethodSelId _ = False
537 isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True
538 isDefaultMethodId other = False
540 isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _)
541 = Just (cls, clsop, err)
542 isDefaultMethodId_maybe other = Nothing
544 isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True
545 isDictFunId other = False
547 isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True
548 isConstMethodId other = False
550 isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _)
551 = Just (cls, ty, clsop)
552 isConstMethodId_maybe other = Nothing
554 isSuperDictSelId_maybe (Id _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
555 isSuperDictSelId_maybe other_id = Nothing
557 isWorkerId (Id _ _ (WorkerId _) _ _) = True
558 isWorkerId other = False
561 isWrapperId id = workerExists (getIdStrictness id)
567 pprIdInUnfolding :: IdSet -> Id -> Pretty
569 pprIdInUnfolding in_scopes v
574 if v `elementOfUniqSet` in_scopes then
575 pprUnique (getItsUnique v)
577 -- ubiquitous Ids with special syntax:
578 else if v == nilDataCon then
580 else if isTupleCon v then
581 ppBeside (ppPStr SLIT("_TUP_")) (ppInt (getDataConArity v))
583 -- ones to think about:
586 (Id _ _ v_details _ _) = v
589 -- these ones must have been exported by their original module
590 ImportedId _ -> pp_full_name
591 PreludeId _ -> pp_full_name
593 -- these ones' exportedness checked later...
594 TopLevId _ -> pp_full_name
595 DataConId _ _ _ _ _ _ _ -> pp_full_name
597 -- class-ish things: class already recorded as "mentioned"
599 -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
601 -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
602 DefaultMethodId c o _
603 -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
605 -- instance-ish things: should we try to figure out
606 -- *exactly* which extra instances have to be exported? (ToDo)
608 -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
609 ConstMethodId c t o _ _
610 -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
612 -- specialisations and workers
613 SpecId unspec ty_maybes _
615 pp = pprIdInUnfolding in_scopes unspec
617 ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
618 ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
623 pp = pprIdInUnfolding in_scopes unwrkr
625 ppBeside (ppPStr SLIT("_WRKR_ ")) pp
627 -- anything else? we're nae interested
628 other_id -> panic "pprIdInUnfolding:mystery Id"
630 ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
634 (m_str, n_str) = getOrigName v
637 if isAvarop n_str || isAconop n_str then
638 ppBesides [ppLparen, ppPStr n_str, ppRparen]
642 if fromPreludeCore v then
645 ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
647 pp_class :: Class -> Pretty
648 pp_class_op :: ClassOp -> Pretty
649 pp_type :: Type -> Pretty
650 pp_ty_maybe :: Maybe Type -> Pretty
652 pp_class clas = ppr ppr_Unfolding clas
653 pp_class_op op = ppr ppr_Unfolding op
655 pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
657 pp_ty_maybe Nothing = ppPStr SLIT("_N_")
658 pp_ty_maybe (Just t) = pp_type t
662 @whatsMentionedInId@ ferrets out the types/classes/instances on which
663 this @Id@ depends. If this Id is to appear in an interface, then
664 those entities had Jolly Well be in scope. Someone else up the
665 call-tree decides that.
670 :: IdSet -- Ids known to be in scope
671 -> Id -- Id being processed
672 -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
674 whatsMentionedInId in_scopes v
679 = getMentionedTyConsAndClassesFromType v_ty
681 result0 id_bag = (id_bag, tycons, clss)
684 = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
685 tcs `unionBags` tycons,
689 if v `elementOfUniqSet` in_scopes then
690 result0 emptyBag -- v not added to "mentioned"
692 -- ones to think about:
695 (Id _ _ v_details _ _) = v
698 -- specialisations and workers
699 SpecId unspec ty_maybes _
701 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
703 result1 ids2 tcs2 cs2
707 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
709 result1 ids2 tcs2 cs2
711 anything_else -> result0 (unitBag v) -- v is added to "mentioned"
715 Tell them who my wrapper function is.
718 myWrapperMaybe :: Id -> Maybe Id
720 myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
721 myWrapperMaybe other_id = Nothing
726 unfoldingUnfriendlyId -- return True iff it is definitely a bad
727 :: Id -- idea to export an unfolding that
728 -> Bool -- mentions this Id. Reason: it cannot
729 -- possibly be seen in another module.
731 unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
734 unfoldingUnfriendlyId id
735 | not (externallyVisibleId id) -- that settles that...
738 unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _)
739 = class_thing wrapper
741 -- "class thing": If we're going to use this worker Id in
742 -- an interface, we *have* to be able to untangle the wrapper's
743 -- strictness when reading it back in. At the moment, this
744 -- is not always possible: in precisely those cases where
745 -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
747 class_thing (Id _ _ (SuperDictSelId _ _) _ _) = True
748 class_thing (Id _ _ (MethodSelId _ _) _ _) = True
749 class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True
750 class_thing other = False
752 unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _)
753 -- a SPEC of a DictFunId can end up w/ gratuitous
754 -- TyVar(Templates) in the i/face; only a problem
755 -- if -fshow-pragma-name-errs; but we can do without the pain.
756 -- A HACK in any case (WDP 94/05/02)
757 = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
758 naughty_DictFunId dfun
761 unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
762 = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
763 naughty_DictFunId dfun -- similar deal...
766 unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
768 naughty_DictFunId :: IdDetails -> Bool
769 -- True <=> has a TyVar(Template) in the "type" part of its "name"
771 naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
772 naughty_DictFunId (DictFunId _ ty _ _)
773 = not (isGroundTy ty)
777 @externallyVisibleId@: is it true that another module might be
778 able to ``see'' this Id?
780 We need the @toplevelishId@ check as well as @isExported@ for when we
781 compile instance declarations in the prelude. @DictFunIds@ are
782 ``exported'' if either their class or tycon is exported, but, in
783 compiling the prelude, the compiler may not recognise that as true.
786 externallyVisibleId :: Id -> Bool
788 externallyVisibleId id = panic "Id.externallyVisibleId"
791 externallyVisibleId id@(Id _ _ details _ _)
792 = if isLocallyDefined id then
793 toplevelishId id && isExported id && not (weird_datacon details)
795 not (weird_tuplecon details)
796 -- if visible here, it must be visible elsewhere, too.
798 -- If it's a DataCon, it's not enough to know it (meaning
799 -- its TyCon) is exported; we need to know that it might
800 -- be visible outside. Consider:
802 -- data Foo a = Mumble | BigFoo a WeirdLocalType
804 -- We can't tell the outside world *anything* about Foo, because
805 -- of WeirdLocalType; but we need to know this when asked if
806 -- "Mumble" is externally visible...
808 weird_datacon (DataConId _ _ _ _ _ _ tycon)
809 = maybeToBool (maybePurelyLocalTyCon tycon)
810 weird_datacon not_a_datacon_therefore_not_weird = False
812 weird_tuplecon (TupleConId arity)
813 = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
814 weird_tuplecon _ = False
819 idWantsToBeINLINEd :: Id -> Bool
821 idWantsToBeINLINEd id
822 = panic "Id.idWantsToBeINLINEd"
824 = case (getIdUnfolding id) of
825 IWantToBeINLINEd _ -> True
830 For @unlocaliseId@: See the brief commentary in
831 \tr{simplStg/SimplStg.lhs}.
835 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
837 unlocaliseId mod (Id u ty info (TopLevId fn))
838 = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
840 unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
841 = --false?: ASSERT(no_ftvs)
843 full_name = unlocaliseShortName mod u sn
845 Just (Id u ty info (TopLevId full_name))
847 unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
848 = --false?: on PreludeGlaST: ASSERT(no_ftvs)
850 full_name = unlocaliseShortName mod u sn
852 Just (Id u ty info (TopLevId full_name))
854 unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
855 = case unlocalise_parent mod u unspec of
857 Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))
859 unlocaliseId mod (Id u ty info (WorkerId unwrkr))
860 = case unlocalise_parent mod u unwrkr of
862 Just xx -> Just (Id u ty info (WorkerId xx))
864 unlocaliseId mod (Id u ty info (InstId name))
865 = Just (Id u ty info (TopLevId full_name))
866 -- type might be wrong, but it hardly matters
867 -- at this stage (just before printing C) ToDo
869 name = getLocalName name
870 full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
872 unlocaliseId mod other_id = Nothing
875 -- we have to be Very Careful for workers/specs of
878 unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs))
879 = --false?: ASSERT(no_ftvs)
881 full_name = unlocaliseShortName mod uniq sn
883 Just (Id uniq ty info (TopLevId full_name))
885 unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
886 = --false?: ASSERT(no_ftvs)
888 full_name = unlocaliseShortName mod uniq sn
890 Just (Id uniq ty info (TopLevId full_name))
892 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
893 -- we're OK otherwise
897 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
898 `Top-levelish Ids'' cannot have any free type variables, so applying
899 the type-env cannot have any effect. (NB: checked in CoreLint?)
901 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
902 former ``should be'' the usual crunch point.
906 applyTypeEnvToId :: TypeEnv -> Id -> Id
908 applyTypeEnvToId type_env id@(Id u ty info details)
909 | idHasNoFreeTyVars id
912 = apply_to_Id ( \ ty ->
913 applyTypeEnvToTy type_env ty
920 apply_to_Id :: (Type -> Type)
924 apply_to_Id ty_fn (Id u ty info details)
925 = Id u (ty_fn ty) (apply_to_IdInfo ty_fn info) (apply_to_details details)
927 apply_to_details (InstId inst)
929 new_inst = apply_to_Inst ty_fn inst
933 apply_to_details (SpecId unspec ty_maybes no_ftvs)
935 new_unspec = apply_to_Id ty_fn unspec
936 new_maybes = map apply_to_maybe ty_maybes
938 SpecId new_unspec new_maybes no_ftvs
939 -- ToDo: recalc no_ftvs????
941 apply_to_maybe Nothing = Nothing
942 apply_to_maybe (Just ty) = Just (ty_fn ty)
944 apply_to_details (WorkerId unwrkr)
946 new_unwrkr = apply_to_Id ty_fn unwrkr
950 apply_to_details other = other
954 Sadly, I don't think the one using the magic typechecker substitution
955 can be done with @apply_to_Id@. Here we go....
957 Strictness is very important here. We can't leave behind thunks
958 with pointers to the substitution: it {\em must} be single-threaded.
962 applySubstToId :: Subst -> Id -> (Subst, Id)
964 applySubstToId subst id@(Id u ty info details)
965 -- *cannot* have a "idHasNoFreeTyVars" get-out clause
966 -- because, in the typechecker, we are still
967 -- *concocting* the types.
968 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
969 case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
970 case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
971 (s4, Id u new_ty new_info new_details) }}}
973 apply_to_details subst _ (InstId inst)
974 = case (applySubstToInst subst inst) of { (s2, new_inst) ->
975 (s2, InstId new_inst) }
977 apply_to_details subst new_ty (SpecId unspec ty_maybes _)
978 = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
979 case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
980 (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
981 -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
983 apply_to_maybe subst Nothing = (subst, Nothing)
984 apply_to_maybe subst (Just ty)
985 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
988 apply_to_details subst _ (WorkerId unwrkr)
989 = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
990 (s2, WorkerId new_unwrkr) }
992 apply_to_details subst _ other = (subst, other)
997 getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
998 getIdNamePieces show_uniqs id
999 = get (unsafeGenId2Id id)
1001 get (Id u _ details _ _)
1003 DataConId n _ _ _ _ _ _ ->
1004 case (getOrigName n) of { (mod, name) ->
1005 if fromPrelude mod then [name] else [mod, name] }
1007 TupleConId 0 -> [SLIT("()")]
1008 TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )]
1010 ImportedId n -> get_fullname_pieces n
1011 PreludeId n -> get_fullname_pieces n
1012 TopLevId n -> get_fullname_pieces n
1014 SuperDictSelId c sc ->
1015 case (getOrigName c) of { (c_mod, c_name) ->
1016 case (getOrigName sc) of { (sc_mod, sc_name) ->
1018 c_bits = if fromPreludeCore c
1020 else [c_mod, c_name]
1022 sc_bits= if fromPreludeCore sc
1024 else [sc_mod, sc_name]
1026 [SLIT("sdsel")] ++ c_bits ++ sc_bits }}
1028 MethodSelId clas op ->
1029 case (getOrigName clas) of { (c_mod, c_name) ->
1030 case (getClassOpString op) of { op_name ->
1031 if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name]
1034 DefaultMethodId clas op _ ->
1035 case (getOrigName clas) of { (c_mod, c_name) ->
1036 case (getClassOpString op) of { op_name ->
1037 if fromPreludeCore clas
1038 then [SLIT("defm"), op_name]
1039 else [SLIT("defm"), c_mod, c_name, op_name] }}
1041 DictFunId c ty _ _ ->
1042 case (getOrigName c) of { (c_mod, c_name) ->
1044 c_bits = if fromPreludeCore c
1046 else [c_mod, c_name]
1048 ty_bits = getTypeString ty
1050 [SLIT("dfun")] ++ c_bits ++ ty_bits }
1053 ConstMethodId c ty o _ _ ->
1054 case (getOrigName c) of { (c_mod, c_name) ->
1055 case (getTypeString ty) of { ty_bits ->
1056 case (getClassOpString o) of { o_name ->
1057 case (if fromPreludeCore c
1059 else [c_mod, c_name]) of { c_bits ->
1060 [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
1062 -- if the unspecialised equiv is "top-level",
1063 -- the name must be concocted from its name and the
1064 -- names of the types to which specialised...
1066 SpecId unspec ty_maybes _ ->
1067 get unspec ++ (if not (toplevelishId unspec)
1069 else concat (map typeMaybeString ty_maybes))
1072 get unwrkr ++ (if not (toplevelishId unwrkr)
1076 LocalId n _ -> let local = getLocalName n in
1077 if show_uniqs then [local, showUnique u] else [local]
1078 InstId n -> [getLocalName n, showUnique u]
1079 SysLocalId n _ -> [getLocalName n, showUnique u]
1080 SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
1082 get_fullname_pieces :: FullName -> [FAST_STRING]
1083 get_fullname_pieces n
1084 = BIND (getOrigName n) _TO_ (mod, name) ->
1091 %************************************************************************
1093 \subsection[Id-type-funs]{Type-related @Id@ functions}
1095 %************************************************************************
1098 idType :: GenId ty -> ty
1100 idType (Id _ ty _ _ _) = ty
1105 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1107 getMentionedTyConsAndClassesFromId id
1108 = getMentionedTyConsAndClassesFromType (idType id)
1113 --getIdPrimRep i = primRepFromType (idType i)
1118 getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
1119 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
1120 getInstIdModule other = panic "Id:getInstIdModule"
1124 %************************************************************************
1126 \subsection[Id-overloading]{Functions related to overloading}
1128 %************************************************************************
1131 mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
1132 mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
1133 mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
1135 mkDictFunId u c ity full_ty from_here modname info
1136 = Id u full_ty (DictFunId c ity from_here modname) NoPragmaInfo info
1138 mkConstMethodId u c op ity full_ty from_here modname info
1139 = Id u full_ty (ConstMethodId c ity op from_here modname) NoPragmaInfo info
1141 mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
1143 mkInstId uniq ty name = Id uniq ty (InstId name) NoPragmaInfo noIdInfo
1146 getConstMethodId clas op ty
1147 = -- constant-method info is hidden in the IdInfo of
1148 -- the class-op id (as mentioned up above).
1150 sel_id = getMethodSelId clas op
1152 case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1154 Nothing -> error (ppShow 80 (ppAboves [
1155 ppCat [ppStr "ERROR: getConstMethodId:", ppr PprDebug op,
1156 ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1157 ppr PprDebug sel_id],
1158 ppStr "(This can arise if an interface pragma refers to an instance",
1159 ppStr "but there is no imported interface which *defines* that instance.",
1160 ppStr "The info above, however ugly, should indicate what else you need to import."
1165 %************************************************************************
1167 \subsection[local-funs]{@LocalId@-related functions}
1169 %************************************************************************
1172 mkImported u n ty info = Id u ty (ImportedId n) NoPragmaInfo info
1173 mkPreludeId u n ty info = Id u ty (PreludeId n) NoPragmaInfo info
1176 updateIdType :: Id -> Type -> Id
1177 updateIdType (Id u _ info details) ty = Id u ty info details
1182 type MyTy a b = GenType (GenTyVar a) b
1183 type MyId a b = GenId (MyTy a b)
1185 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1187 -- SysLocal: for an Id being created by the compiler out of thin air...
1188 -- UserLocal: an Id with a name the user might recognize...
1189 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1191 mkSysLocal str uniq ty loc
1192 = Id uniq ty (SysLocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1194 mkUserLocal str uniq ty loc
1195 = Id uniq ty (LocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1197 -- mkUserId builds a local or top-level Id, depending on the name given
1198 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1199 mkUserId (Short uniq short) ty pragma_info
1200 = Id uniq ty (LocalId short (no_free_tvs ty)) pragma_info noIdInfo
1201 mkUserId (ValName uniq full) ty pragma_info
1203 (if isLocallyDefined full then TopLevId full else ImportedId full)
1204 pragma_info noIdInfo
1211 -- for a SpecPragmaId being created by the compiler out of thin air...
1212 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1213 mkSpecPragmaId str uniq ty specid loc
1214 = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
1217 mkSpecId u unspec ty_maybes ty info
1218 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1219 Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1221 -- Specialised version of constructor: only used in STG and code generation
1222 -- Note: The specialsied Id has the same unique as the unspeced Id
1224 mkSameSpecCon ty_maybes unspec@(Id u ty info details)
1225 = ASSERT(isDataCon unspec)
1226 ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1227 Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1229 new_ty = specialiseTy ty ty_maybes 0
1231 -- pprTrace "SameSpecCon:Unique:"
1232 -- (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes]))
1234 localiseId :: Id -> Id
1235 localiseId id@(Id u ty info details)
1236 = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
1238 name = getOccurrenceName id
1241 -- this has to be one of the "local" flavours (LocalId, SysLocalId, InstId)
1242 -- ToDo: it does??? WDP
1243 mkIdWithNewUniq :: Id -> Unique -> Id
1245 mkIdWithNewUniq (Id _ ty info details) uniq
1246 = Id uniq ty info new_details
1250 Make some local @Ids@ for a template @CoreExpr@. These have bogus
1251 @Uniques@, but that's OK because the templates are supposed to be
1252 instantiated before use.
1255 mkTemplateLocals :: [Type] -> [Id]
1256 mkTemplateLocals tys
1257 = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc)
1258 (getBuiltinUniques (length tys))
1264 getIdInfo :: GenId ty -> IdInfo
1265 getPragmaInfo :: GenId ty -> PragmaInfo
1267 getIdInfo (Id _ _ _ _ info) = info
1268 getPragmaInfo (Id _ _ _ info _) = info
1271 replaceIdInfo :: Id -> IdInfo -> Id
1273 replaceIdInfo (Id u ty _ details) info = Id u ty info details
1275 selectIdInfoForSpecId :: Id -> IdInfo
1276 selectIdInfoForSpecId unspec
1277 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1278 noIdInfo `addInfo_UF` getIdUnfolding unspec
1282 %************************************************************************
1284 \subsection[Id-arities]{Arity-related functions}
1286 %************************************************************************
1288 For locally-defined Ids, the code generator maintains its own notion
1289 of their arities; so it should not be asking... (but other things
1290 besides the code-generator need arity info!)
1293 getIdArity :: Id -> ArityInfo
1294 getIdArity (Id _ _ _ _ id_info) = getInfo id_info
1296 getDataConArity :: DataCon -> Int
1297 getDataConArity id@(Id _ _ _ _ id_info)
1298 = ASSERT(isDataCon id)
1299 case (arityMaybe (getInfo id_info)) of
1300 Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id)
1303 addIdArity :: Id -> Int -> Id
1304 addIdArity (Id u ty details pinfo info) arity
1305 = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
1308 %************************************************************************
1310 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1312 %************************************************************************
1315 mkDataCon :: Unique{-DataConKey-}
1318 -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1321 -- can get the tag and all the pieces of the type from the Type
1323 mkDataCon k n stricts tvs ctxt args_tys tycon
1324 = ASSERT(length stricts == length args_tys)
1327 -- NB: data_con self-recursion; should be OK as tags are not
1328 -- looked at until late in the game.
1332 (DataConId n data_con_tag stricts tvs ctxt args_tys tycon)
1336 data_con_tag = position_within fIRST_TAG data_con_family
1338 data_con_family = getTyConDataCons tycon
1340 position_within :: Int -> [Id] -> Int
1342 position_within acc (c:cs)
1343 = if c == data_con then acc else position_within (acc+1) cs
1345 position_within acc []
1346 = panic "mkDataCon: con not found in family"
1350 = mkSigmaTy tvs ctxt
1351 (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1353 datacon_info = noIdInfo `addInfo_UF` unfolding
1354 `addInfo` mkArityInfo arity
1355 --ToDo: `addInfo` specenv
1357 arity = length args_tys
1364 -- else -- do some business...
1366 (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1367 tyvar_tys = mkTyVarTys tyvars
1369 BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1371 mkUnfolding EssentialUnfolding -- for data constructors
1372 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1375 mk_uf_bits tvs ctxt arg_tys tycon
1377 (inst_env, tyvars, tyvar_tys)
1378 = instantiateTyVarTemplates tvs
1379 (map getItsUnique tvs)
1381 -- the "context" and "arg_tys" have TyVarTemplates in them, so
1382 -- we instantiate those types to have the right TyVars in them
1384 BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1385 _TO_ inst_dict_tys ->
1386 BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys ->
1388 -- We can only have **ONE** call to mkTemplateLocals here;
1389 -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1390 -- (Mega-Sigh) [ToDo]
1391 BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
1393 BIND (splitAt (length ctxt) all_vars) _TO_ (dict_vars, vars) ->
1395 (tyvars, dict_vars, vars)
1398 -- these are really dubious Types, but they are only to make the
1399 -- binders for the lambdas for tossed-away dicts.
1400 ctxt_ty (clas, ty) = mkDictTy clas ty
1405 mkTupleCon :: Arity -> Id
1408 = Id unique ty (TupleConId arity) NoPragmaInfo tuplecon_info
1410 unique = mkTupleDataConUnique arity
1411 ty = mkSigmaTy tyvars []
1412 (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1413 tycon = mkTupleTyCon arity
1414 tyvars = take arity alphaTyVars
1415 tyvar_tys = mkTyVarTys tyvars
1418 = noIdInfo `addInfo_UF` unfolding
1419 `addInfo` mkArityInfo arity
1420 --LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1427 -- else -- do some business...
1429 (tyvars, dict_vars, vars) = mk_uf_bits arity
1430 tyvar_tys = mkTyVarTys tyvars
1432 BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1435 EssentialUnfolding -- data constructors
1436 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1440 = BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
1444 tyvar_tmpls = take arity alphaTyVars
1445 (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
1449 fIRST_TAG = 1 -- Tags allocated from here for real constructors
1453 getDataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1454 getDataConTag (Id _ _ (DataConId _ tag _ _ _ _ _) _ _) = tag
1455 getDataConTag (Id _ _ (TupleConId _) _ _) = fIRST_TAG
1456 getDataConTag (Id _ _ (SpecId unspec _ _) _ _) = getDataConTag unspec
1458 getDataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
1459 getDataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
1460 getDataConTyCon (Id _ _ (TupleConId a) _ _) = mkTupleTyCon a
1462 getDataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1463 -- will panic if not a DataCon
1465 getDataConSig (Id _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1466 = (tyvars, theta_ty, arg_tys, tycon)
1468 getDataConSig (Id _ _ (TupleConId arity) _ _)
1469 = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1471 tyvars = take arity alphaTyVars
1472 tyvar_tys = mkTyVarTys tyvars
1476 getDataConTyCon (Id _ _ _ (SpecId unspec tys _))
1477 = mkSpecTyCon (getDataConTyCon unspec) tys
1479 getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
1480 = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
1482 (tyvars, theta_ty, arg_tys, tycon) = getDataConSig unspec
1484 ty_env = tyvars `zip` ty_maybes
1486 spec_tyvars = foldr nothing_tyvars [] ty_env
1487 nothing_tyvars (tyvar, Nothing) l = tyvar : l
1488 nothing_tyvars (tyvar, Just ty) l = l
1490 spec_env = foldr just_env [] ty_env
1491 just_env (tyvar, Nothing) l = l
1492 just_env (tyvar, Just ty) l = (tyvar, ty) : l
1493 spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
1495 spec_theta_ty = if null theta_ty then []
1496 else panic "getDataConSig:ThetaTy:SpecDataCon"
1497 spec_tycon = mkSpecTyCon tycon ty_maybes
1502 @getInstantiatedDataConSig@ takes a constructor and some types to which
1503 it is applied; it returns its signature instantiated to these types.
1506 getInstantiatedDataConSig ::
1507 DataCon -- The data constructor
1508 -- Not a specialised data constructor
1509 -> [TauType] -- Types to which applied
1510 -- Must be fully applied i.e. contain all types of tycon
1511 -> ([TauType], -- Types of dict args
1512 [TauType], -- Types of regular args
1513 TauType -- Type of result
1516 getInstantiatedDataConSig data_con inst_tys
1517 = ASSERT(isDataCon data_con)
1519 (tvs, theta, arg_tys, tycon) = getDataConSig data_con
1521 inst_env = ASSERT(length tvs == length inst_tys)
1524 theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ]
1525 cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ]
1526 result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys)
1528 -- Are the first/third results ever used?
1529 (theta_tys, cmpnt_tys, result_ty)
1532 Data type declarations are of the form:
1534 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1536 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1537 @C1 x y z@, we want a function binding:
1539 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1541 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1542 2nd-order polymorphic lambda calculus with explicit types.
1544 %************************************************************************
1546 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1548 %************************************************************************
1550 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1551 and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
1552 @TyVars@ don't really have to be new, because we are only producing a
1555 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1558 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1559 EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the
1560 example above: a, b, and x, y, z], which is enough (in the important
1561 \tr{DsExpr} case). (The middle set of @Ids@ is binders for any
1562 dictionaries, in the even of an overloaded data-constructor---none at
1566 getIdUnfolding :: Id -> UnfoldingDetails
1568 getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info
1571 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1572 addIdUnfolding id@(Id u ty info details) unfold_details
1574 case (isLocallyDefined id, unfold_details) of
1575 (_, NoUnfoldingDetails) -> True
1576 (True, IWantToBeINLINEd _) -> True
1577 (False, IWantToBeINLINEd _) -> False -- v bad
1581 Id u ty (info `addInfo_UF` unfold_details) details
1585 In generating selector functions (take a dictionary, give back one
1586 component...), we need to what out for the nothing-to-select cases (in
1587 which case the ``selector'' is just an identity function):
1589 class Eq a => Foo a { } # the superdict selector for "Eq"
1591 class Foo a { op :: Complex b => c -> b -> a }
1592 # the method selector for "op";
1593 # note local polymorphism...
1596 %************************************************************************
1598 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1600 %************************************************************************
1603 getIdDemandInfo :: Id -> DemandInfo
1604 getIdDemandInfo (Id _ _ _ _ info) = getInfo info
1606 addIdDemandInfo :: Id -> DemandInfo -> Id
1607 addIdDemandInfo (Id u ty details prags info) demand_info
1608 = Id u ty details prags (info `addInfo` demand_info)
1612 getIdUpdateInfo :: Id -> UpdateInfo
1613 getIdUpdateInfo (Id _ _ _ _ info) = getInfo info
1615 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1616 addIdUpdateInfo (Id u ty details prags info) upd_info
1617 = Id u ty details prags (info `addInfo` upd_info)
1622 getIdArgUsageInfo :: Id -> ArgUsageInfo
1623 getIdArgUsageInfo (Id u ty info details) = getInfo info
1625 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1626 addIdArgUsageInfo (Id u ty info details) au_info
1627 = Id u ty (info `addInfo` au_info) details
1633 getIdFBTypeInfo :: Id -> FBTypeInfo
1634 getIdFBTypeInfo (Id u ty info details) = getInfo info
1636 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1637 addIdFBTypeInfo (Id u ty info details) upd_info
1638 = Id u ty (info `addInfo` upd_info) details
1644 getIdSpecialisation :: Id -> SpecEnv
1645 getIdSpecialisation (Id _ _ _ _ info) = getInfo info
1647 addIdSpecialisation :: Id -> SpecEnv -> Id
1648 addIdSpecialisation (Id u ty details prags info) spec_info
1649 = Id u ty details prags (info `addInfo` spec_info)
1653 Strictness: we snaffle the info out of the IdInfo.
1656 getIdStrictness :: Id -> StrictnessInfo
1658 getIdStrictness (Id _ _ _ _ info) = getInfo info
1660 addIdStrictness :: Id -> StrictnessInfo -> Id
1662 addIdStrictness (Id u ty details prags info) strict_info
1663 = Id u ty details prags (info `addInfo` strict_info)
1666 %************************************************************************
1668 \subsection[Id-comparison]{Comparison functions for @Id@s}
1670 %************************************************************************
1672 Comparison: equality and ordering---this stuff gets {\em hammered}.
1675 cmpId (Id u1 _ _ _ _) (Id u2 _ _ _ _) = cmp u1 u2
1676 -- short and very sweet
1680 instance Ord3 (GenId ty) where
1683 instance Eq (GenId ty) where
1684 a == b = case cmpId a b of { EQ_ -> True; _ -> False }
1685 a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
1687 instance Ord (GenId ty) where
1688 a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
1689 a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
1690 a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
1691 a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
1692 _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1695 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1696 account when comparing two data constructors. We need to do this
1697 because a specialised data constructor has the same Unique as its
1698 unspecialised counterpart.
1702 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1704 cmpId_withSpecDataCon id1 id2
1705 | eq_ids && isDataCon id1 && isDataCon id2
1706 = cmpEqDataCon id1 id2
1711 cmp_ids = cmpId id1 id2
1712 eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
1714 cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _)) (Id _ _ _ (SpecId _ mtys2 _))
1715 = cmpUniTypeMaybeList mtys1 mtys2
1717 cmpEqDataCon unspec1 (Id _ _ _ (SpecId _ _ _))
1720 cmpEqDataCon (Id _ _ _ (SpecId _ _ _)) unspec2
1723 cmpEqDataCon unspec1 unspec2
1728 %************************************************************************
1730 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1732 %************************************************************************
1735 instance Outputable ty => Outputable (GenId ty) where
1736 ppr sty id = pprId sty id
1738 showId :: PprStyle -> Id -> String
1739 showId sty id = ppShow 80 (pprId sty id)
1742 -- for DictFuns (instances) and const methods (instance code bits we
1743 -- can call directly): exported (a) if *either* the class or
1744 -- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
1745 -- class and tycon are from PreludeCore [non-std, but convenient]
1746 -- *and* the thing was defined in this module.
1748 instance_export_flag :: Class -> Type -> Bool -> ExportFlag
1750 instance_export_flag clas inst_ty from_here
1751 = panic "Id:instance_export_flag"
1753 = if instanceIsExported clas inst_ty from_here
1759 Do we consider an ``instance type'' (as on a @DictFunId@) to be ``from
1760 PreludeCore''? True if the outermost TyCon is fromPreludeCore.
1762 is_prelude_core_ty :: Type -> Bool
1764 is_prelude_core_ty inst_ty
1765 = panic "Id.is_prelude_core_ty"
1767 = case maybeAppDataTyCon inst_ty of
1768 Just (tycon,_,_) -> fromPreludeCore tycon
1769 Nothing -> panic "Id: is_prelude_core_ty"
1773 Default printing code (not used for interfaces):
1775 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1779 pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
1781 for_code = panic "pprId: for code"
1783 pieces_to_print -- maybe use Unique only
1784 = if isSysLocalId id then tail pieces else pieces
1786 ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
1791 PprForAsm _ _ -> for_code
1792 PprInterface -> ppPStr occur_name
1793 PprForUser -> ppPStr occur_name
1794 PprUnfolding -> qualified_name pieces
1795 PprDebug -> qualified_name pieces
1796 PprShowAll -> ppBesides [qualified_name pieces,
1799 ppr other_sty (idType id),
1800 ppIdInfo other_sty (unsafeGenId2Id id) True
1801 (\x->x) nullIdEnv (getIdInfo id),
1802 ppPStr SLIT("-}") ])]
1804 occur_name = getOccurrenceName id _APPEND_
1805 ( _PK_ (if not (isSysLocalId id)
1807 else "." ++ (_UNPK_ (showUnique (getItsUnique id)))))
1809 qualified_name pieces
1810 = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
1812 pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add
1813 pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _) _ _) = ppNil
1814 pp_uniq (Id _ _ (TupleConId _) _ _) = ppNil
1815 pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere
1816 pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil
1817 pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil
1818 pp_uniq (Id _ _ (InstId _) _ _) = ppNil
1819 pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getItsUnique other_id), ppPStr SLIT("-}")]
1821 -- print PprDebug Ids with # afterwards if they are of primitive type.
1822 pp_ubxd pretty = pretty
1824 {- LATER: applying isPrimType restricts type
1825 pp_ubxd pretty = if isPrimType (idType id)
1826 then ppBeside pretty (ppChar '#')
1833 instance NamedThing (GenId ty) where
1834 getExportFlag (Id _ _ details _ _)
1837 get (DataConId _ _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
1838 get (TupleConId _) = NotExported
1839 get (ImportedId n) = getExportFlag n
1840 get (PreludeId n) = getExportFlag n
1841 get (TopLevId n) = getExportFlag n
1842 get (SuperDictSelId c _) = getExportFlag c
1843 get (MethodSelId c _) = getExportFlag c
1844 get (DefaultMethodId c _ _) = getExportFlag c
1845 get (DictFunId c ty from_here _) = instance_export_flag c ty from_here
1846 get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here
1847 get (SpecId unspec _ _) = getExportFlag unspec
1848 get (WorkerId unwrkr) = getExportFlag unwrkr
1849 get (InstId _) = NotExported
1850 get (LocalId _ _) = NotExported
1851 get (SysLocalId _ _) = NotExported
1852 get (SpecPragmaId _ _ _) = NotExported
1854 isLocallyDefined this_id@(Id _ _ details _ _)
1857 get (DataConId _ _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
1858 get (TupleConId _) = False
1859 get (ImportedId _) = False
1860 get (PreludeId _) = False
1861 get (TopLevId n) = isLocallyDefined n
1862 get (SuperDictSelId c _) = isLocallyDefined c
1863 get (MethodSelId c _) = isLocallyDefined c
1864 get (DefaultMethodId c _ _) = isLocallyDefined c
1865 get (DictFunId c tyc from_here _) = from_here
1866 -- For DictFunId and ConstMethodId things, you really have to
1867 -- know whether it came from an imported instance or one
1868 -- really here; no matter where the tycon and class came from.
1870 get (ConstMethodId c tyc _ from_here _) = from_here
1871 get (SpecId unspec _ _) = isLocallyDefined unspec
1872 get (WorkerId unwrkr) = isLocallyDefined unwrkr
1873 get (InstId _) = True
1874 get (LocalId _ _) = True
1875 get (SysLocalId _ _) = True
1876 get (SpecPragmaId _ _ _) = True
1878 getOrigName this_id@(Id u _ details _ _)
1881 get (DataConId n _ _ _ _ _ _) = getOrigName n
1882 get (TupleConId 0) = (pRELUDE_BUILTIN, SLIT("()"))
1883 get (TupleConId a) = (pRELUDE_BUILTIN, _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" ))
1884 get (ImportedId n) = getOrigName n
1885 get (PreludeId n) = getOrigName n
1886 get (TopLevId n) = getOrigName n
1888 get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ???
1889 (mod, _) -> (mod, getClassOpString op)
1892 get (SpecId unspec ty_maybes _)
1893 = BIND getOrigName unspec _TO_ (mod, unspec_nm) ->
1894 BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
1897 (if not (toplevelishId unspec)
1903 get (WorkerId unwrkr)
1904 = BIND getOrigName unwrkr _TO_ (mod, unwrkr_nm) ->
1907 (if not (toplevelishId unwrkr)
1914 get (InstId n) = (panic "NamedThing.Id.getOrigName (LocalId)",
1916 get (LocalId n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
1918 get (SysLocalId n _) = (panic "NamedThing.Id.getOrigName (SysLocal)",
1920 get (SpecPragmaId n _ _)= (panic "NamedThing.Id.getOrigName (SpecPragmaId)",
1924 -- the remaining internally-generated flavours of
1925 -- Ids really do not have meaningful "original name" stuff,
1926 -- but we need to make up something (usually for debugging output)
1928 = BIND (getIdNamePieces True this_id) _TO_ (piece1:pieces) ->
1929 BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
1930 (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
1933 getOccurrenceName this_id@(Id _ _ details _ _)
1936 get (DataConId n _ _ _ _ _ _) = getOccurrenceName n
1937 get (TupleConId 0) = SLIT("()")
1938 get (TupleConId a) = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
1939 get (ImportedId n) = getOccurrenceName n
1940 get (PreludeId n) = getOccurrenceName n
1941 get (TopLevId n) = getOccurrenceName n
1942 get (MethodSelId _ op) = getClassOpString op
1943 get _ = snd (getOrigName this_id)
1945 getInformingModules id = panic "getInformingModule:Id"
1947 getSrcLoc (Id _ _ details _ id_info)
1950 get (DataConId n _ _ _ _ _ _) = getSrcLoc n
1951 get (TupleConId _) = mkBuiltinSrcLoc
1952 get (ImportedId n) = getSrcLoc n
1953 get (PreludeId n) = getSrcLoc n
1954 get (TopLevId n) = getSrcLoc n
1955 get (SuperDictSelId c _)= getSrcLoc c
1956 get (MethodSelId c _) = getSrcLoc c
1957 get (SpecId unspec _ _) = getSrcLoc unspec
1958 get (WorkerId unwrkr) = getSrcLoc unwrkr
1959 get (InstId n) = getSrcLoc n
1960 get (LocalId n _) = getSrcLoc n
1961 get (SysLocalId n _) = getSrcLoc n
1962 get (SpecPragmaId n _ _)= getSrcLoc n
1963 -- well, try the IdInfo
1964 get something_else = getSrcLocIdInfo id_info
1966 getItsUnique (Id u _ _ _ _) = u
1968 fromPreludeCore (Id _ _ details _ _)
1971 get (DataConId _ _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
1972 get (TupleConId _) = True
1973 get (ImportedId n) = fromPreludeCore n
1974 get (PreludeId n) = fromPreludeCore n
1975 get (TopLevId n) = fromPreludeCore n
1976 get (SuperDictSelId c _) = fromPreludeCore c
1977 get (MethodSelId c _) = fromPreludeCore c
1978 get (DefaultMethodId c _ _) = fromPreludeCore c
1979 get (DictFunId c t _ _) = fromPreludeCore c && is_prelude_core_ty t
1980 get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t
1981 get (SpecId unspec _ _) = fromPreludeCore unspec
1982 get (WorkerId unwrkr) = fromPreludeCore unwrkr
1983 get (InstId _) = False
1984 get (LocalId _ _) = False
1985 get (SysLocalId _ _) = False
1986 get (SpecPragmaId _ _ _) = False
1989 Reason for @getItsUnique@: The code generator doesn't carry a
1990 @UniqueSupply@, so it wants to use the @Uniques@ out of local @Ids@
1993 %************************************************************************
1995 \subsection{@IdEnv@s and @IdSet@s}
1997 %************************************************************************
2000 type IdEnv elt = UniqFM elt
2002 nullIdEnv :: IdEnv a
2004 mkIdEnv :: [(GenId ty, a)] -> IdEnv a
2005 unitIdEnv :: GenId ty -> a -> IdEnv a
2006 addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
2007 growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
2008 growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
2010 delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
2011 delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
2012 combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
2013 mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
2014 modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
2015 rngIdEnv :: IdEnv a -> [a]
2017 isNullIdEnv :: IdEnv a -> Bool
2018 lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
2019 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
2023 addOneToIdEnv = addToUFM
2024 combineIdEnvs = plusUFM_C
2025 delManyFromIdEnv = delListFromUFM
2026 delOneFromIdEnv = delFromUFM
2028 lookupIdEnv = lookupUFM
2031 nullIdEnv = emptyUFM
2033 unitIdEnv = singletonUFM
2035 growIdEnvList env pairs = plusUFM env (listToUFM pairs)
2036 isNullIdEnv env = sizeUFM env == 0
2037 lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
2039 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
2040 -- modify function, and put it back.
2042 modifyIdEnv env mangle_fn key
2043 = case (lookupIdEnv env key) of
2045 Just xx -> addOneToIdEnv env key (mangle_fn xx)
2049 type GenIdSet ty = UniqSet (GenId ty)
2050 type IdSet = UniqSet (GenId Type)
2052 emptyIdSet :: GenIdSet ty
2053 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
2054 unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
2055 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
2056 idSetToList :: GenIdSet ty -> [GenId ty]
2057 singletonIdSet :: GenId ty -> GenIdSet ty
2058 elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
2059 minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
2060 isEmptyIdSet :: GenIdSet ty -> Bool
2061 mkIdSet :: [GenId ty] -> GenIdSet ty
2063 emptyIdSet = emptyUniqSet
2064 singletonIdSet = singletonUniqSet
2065 intersectIdSets = intersectUniqSets
2066 unionIdSets = unionUniqSets
2067 unionManyIdSets = unionManyUniqSets
2068 idSetToList = uniqSetToList
2069 elementOfIdSet = elementOfUniqSet
2070 minusIdSet = minusUniqSet
2071 isEmptyIdSet = isEmptyUniqSet