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!
86 -- "Environments" keyed off of Ids, and sets of Ids
88 lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
89 growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
90 delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
93 -- and to make the interface self-sufficient...
94 GenIdSet(..), IdSet(..)
98 import IdLoop -- for paranoia checking
99 import TyLoop -- for paranoia checking
102 import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
103 import CStrings ( identToC, cSEP )
105 import Maybes ( maybeToBool )
106 import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
107 isLocallyDefinedName, isPreludeDefinedName,
108 mkTupleDataConName, mkCompoundName,
109 isLexSym, isLexSpecialSym, getLocalName,
110 isLocallyDefined, isPreludeDefined,
111 getOccName, moduleNamePair, origName, nameOf,
112 isExported, ExportFlag(..),
115 import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
116 import PragmaInfo ( PragmaInfo(..) )
117 import PprEnv -- ( NmbrM(..), NmbrEnv(..) )
118 import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
124 import SrcLoc ( mkBuiltinSrcLoc )
125 import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
126 import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
127 applyTyCon, isPrimType, instantiateTy,
128 tyVarsOfType, applyTypeEnvToTy, typePrimRep,
129 GenType, ThetaType(..), TauType(..), Type(..)
131 import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
133 import UniqSet -- practically all of it
134 import Unique ( getBuiltinUniques, pprUnique, showUnique,
136 Unique{-instance Ord3-}
138 import Util ( mapAccumL, nOfThem, zipEqual,
139 panic, panic#, pprPanic, assertPanic
143 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
146 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
147 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
148 strictness). The essential info about different kinds of @Ids@ is
151 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
155 Unique -- Key for fast comparison
156 ty -- Id's type; used all the time;
157 IdDetails -- Stuff about individual kinds of Ids.
158 PragmaInfo -- Properties of this Id requested by programmer
159 -- eg specialise-me, inline-me
160 IdInfo -- Properties of this Id deduced by compiler
164 data StrictnessMark = MarkedStrict | NotMarkedStrict
168 ---------------- Local values
170 = LocalId Name -- Local name; mentioned by the user
171 Bool -- True <=> no free type vars
173 | SysLocalId Name -- Local name; made up by the compiler
174 Bool -- as for LocalId
176 | SpecPragmaId Name -- Local name; introduced by the compiler
177 (Maybe Id) -- for explicit specid in pragma
178 Bool -- as for LocalId
180 ---------------- Global values
182 | ImportedId Name -- Global name (Imported or Implicit); Id imported from an interface
184 | PreludeId Name -- Global name (Builtin); Builtin prelude Ids
186 | TopLevId Name -- Global name (LocalDef); Top-level in the orig source pgm
187 -- (not moved there by transformations).
189 -- a TopLevId's type may contain free type variables, if
190 -- the monomorphism restriction applies.
192 ---------------- Data constructors
196 [StrictnessMark] -- Strict args; length = arity
197 [FieldLabel] -- Field labels for this constructor
199 [TyVar] [(Class,Type)] [Type] TyCon
201 -- forall tyvars . theta_ty =>
202 -- unitype_1 -> ... -> unitype_n -> tycon tyvars
207 | RecordSelId FieldLabel
209 ---------------- Things to do with overloading
211 | SuperDictSelId -- Selector for superclass dictionary
212 Class -- The class (input dict)
213 Class -- The superclass (result dict)
215 | MethodSelId Class -- An overloaded class operation, with
216 -- a fully polymorphic type. Its code
217 -- just selects a method from the
218 -- dictionary. The class.
219 ClassOp -- The operation
221 -- NB: The IdInfo for a MethodSelId has all the info about its
222 -- related "constant method Ids", which are just
223 -- specialisations of this general one.
225 | DefaultMethodId -- Default method for a particular class op
226 Class -- same class, <blah-blah> info as MethodSelId
227 ClassOp -- (surprise, surprise)
228 Bool -- True <=> I *know* this default method Id
229 -- is a generated one that just says
230 -- `error "No default method for <op>"'.
233 | DictFunId Class -- A DictFun is uniquely identified
234 Type -- by its class and type; this type has free type vars,
235 -- whose identity is irrelevant. Eg Class = Eq
237 -- The "a" is irrelevant. As it is too painful to
238 -- actually do comparisons that way, we kindly supply
239 -- a Unique for that purpose.
240 Bool -- True <=> from an instance decl in this mod
241 (Maybe Module) -- module where instance came from; Nothing => Prelude
244 | ConstMethodId -- A method which depends only on the type of the
245 -- instance, and not on any further dictionaries etc.
246 Class -- Uniquely identified by:
247 Type -- (class, type, classop) triple
249 Bool -- True => from an instance decl in this mod
250 (Maybe Module) -- module where instance came from; Nothing => Prelude
252 | InstId Name -- An instance of a dictionary, class operation,
253 -- or overloaded value (Local name)
254 Bool -- as for LocalId
256 | SpecId -- A specialisation of another Id
257 Id -- Id of which this is a specialisation
258 [Maybe Type] -- Types at which it is specialised;
259 -- A "Nothing" says this type ain't relevant.
260 Bool -- True <=> no free type vars; it's not enough
261 -- to know about the unspec version, because
262 -- we may specialise to a type w/ free tyvars
263 -- (i.e., in one of the "Maybe Type" dudes).
265 | WorkerId -- A "worker" for some other Id
266 Id -- Id for which this is a worker
276 DictFunIds are generated from instance decls.
281 instance Foo a => Foo [a] where
284 generates the dict fun id decl
286 dfun.Foo.[*] = \d -> ...
288 The dfun id is uniquely named by the (class, type) pair. Notice, it
289 isn't a (class,tycon) pair any more, because we may get manually or
290 automatically generated specialisations of the instance decl:
292 instance Foo [Int] where
299 The type variables in the name are irrelevant; we print them as stars.
302 Constant method ids are generated from instance decls where
303 there is no context; that is, no dictionaries are needed to
304 construct the method. Example
306 instance Foo Int where
309 Then we get a constant method
314 It is possible, albeit unusual, to have a constant method
315 for an instance decl which has type vars:
317 instance Foo [a] where
321 We get the constant method
325 So a constant method is identified by a class/op/type triple.
326 The type variables in the type are irrelevant.
329 For Ids whose names must be known/deducible in other modules, we have
330 to conjure up their worker's names (and their worker's worker's
331 names... etc) in a known systematic way.
334 %************************************************************************
336 \subsection[Id-documentation]{Documentation}
338 %************************************************************************
342 The @Id@ datatype describes {\em values}. The basic things we want to
343 know: (1)~a value's {\em type} (@idType@ is a very common
344 operation in the compiler); and (2)~what ``flavour'' of value it might
345 be---for example, it can be terribly useful to know that a value is a
349 %----------------------------------------------------------------------
350 \item[@DataConId@:] For the data constructors declared by a @data@
351 declaration. Their type is kept in {\em two} forms---as a regular
352 @Type@ (in the usual place), and also in its constituent pieces (in
353 the ``details''). We are frequently interested in those pieces.
355 %----------------------------------------------------------------------
356 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
357 the infinite family of tuples.
359 %----------------------------------------------------------------------
360 \item[@ImportedId@:] These are values defined outside this module.
361 {\em Everything} we want to know about them must be stored here (or in
364 %----------------------------------------------------------------------
365 \item[@PreludeId@:] ToDo
367 %----------------------------------------------------------------------
368 \item[@TopLevId@:] These are values defined at the top-level in this
369 module; i.e., those which {\em might} be exported (hence, a
370 @Name@). It does {\em not} include those which are moved to the
371 top-level through program transformations.
373 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
374 Theoretically, they could be floated inwards, but there's no known
375 advantage in doing so. This way, we can keep them with the same
376 @Unique@ throughout (no cloning), and, in general, we don't have to be
377 so paranoid about them.
379 In particular, we had the following problem generating an interface:
380 We have to ``stitch together'' info (1)~from the typechecker-produced
381 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
382 what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change}
383 between (1) and (2), you're sunk!
385 %----------------------------------------------------------------------
386 \item[@MethodSelId@:] A selector from a dictionary; it may select either
387 a method or a dictionary for one of the class's superclasses.
389 %----------------------------------------------------------------------
392 @mkDictFunId [a,b..] theta C T@ is the function derived from the
395 instance theta => C (T a b ..) where
398 It builds function @Id@ which maps dictionaries for theta,
399 to a dictionary for C (T a b ..).
401 *Note* that with the ``Mark Jones optimisation'', the theta may
402 include dictionaries for the immediate superclasses of C at the type
405 %----------------------------------------------------------------------
408 %----------------------------------------------------------------------
411 %----------------------------------------------------------------------
414 %----------------------------------------------------------------------
415 \item[@LocalId@:] A purely-local value, e.g., a function argument,
416 something defined in a @where@ clauses, ... --- but which appears in
417 the original program text.
419 %----------------------------------------------------------------------
420 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
421 the original program text; these are introduced by the compiler in
424 %----------------------------------------------------------------------
425 \item[@SpecPragmaId@:] Introduced by the compiler to record
426 Specialisation pragmas. It is dead code which MUST NOT be removed
427 before specialisation.
432 %----------------------------------------------------------------------
435 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
436 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
440 They have no free type variables, so if you are making a
441 type-variable substitution you don't need to look inside them.
443 They are constants, so they are not free variables. (When the STG
444 machine makes a closure, it puts all the free variables in the
445 closure; the above are not required.)
447 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
448 properties, but they may not.
451 %************************************************************************
453 \subsection[Id-general-funs]{General @Id@-related functions}
455 %************************************************************************
458 unsafeGenId2Id :: GenId ty -> Id
459 unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i
461 isDataCon id = is_data (unsafeGenId2Id id)
463 is_data (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = True
464 is_data (Id _ _ (TupleConId _ _) _ _) = True
465 is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec
466 is_data other = False
469 isTupleCon id = is_tuple (unsafeGenId2Id id)
471 is_tuple (Id _ _ (TupleConId _ _) _ _) = True
472 is_tuple (Id _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
473 is_tuple other = False
476 isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _)
477 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
478 Just (unspec, ty_maybes)
479 isSpecId_maybe other_id
482 isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _)
484 isSpecPragmaId_maybe other_id
489 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a
490 nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be
491 defined at top level (returns @True@). This is used to decide whether
492 the @Id@ is a candidate free variable. NB: you are only {\em sure}
493 about something if it returns @True@!
496 toplevelishId :: Id -> Bool
497 idHasNoFreeTyVars :: Id -> Bool
499 toplevelishId (Id _ _ details _ _)
502 chk (DataConId _ _ _ _ _ _ _ _) = True
503 chk (TupleConId _ _) = True
504 chk (RecordSelId _) = True
505 chk (ImportedId _) = True
506 chk (PreludeId _) = True
507 chk (TopLevId _) = True -- NB: see notes
508 chk (SuperDictSelId _ _) = True
509 chk (MethodSelId _ _) = True
510 chk (DefaultMethodId _ _ _) = True
511 chk (DictFunId _ _ _ _) = True
512 chk (ConstMethodId _ _ _ _ _) = True
513 chk (SpecId unspec _ _) = toplevelishId unspec
514 -- depends what the unspecialised thing is
515 chk (WorkerId unwrkr) = toplevelishId unwrkr
516 chk (InstId _ _) = False -- these are local
517 chk (LocalId _ _) = False
518 chk (SysLocalId _ _) = False
519 chk (SpecPragmaId _ _ _) = False
521 idHasNoFreeTyVars (Id _ _ details _ info)
524 chk (DataConId _ _ _ _ _ _ _ _) = True
525 chk (TupleConId _ _) = True
526 chk (RecordSelId _) = True
527 chk (ImportedId _) = True
528 chk (PreludeId _) = True
529 chk (TopLevId _) = True
530 chk (SuperDictSelId _ _) = True
531 chk (MethodSelId _ _) = True
532 chk (DefaultMethodId _ _ _) = True
533 chk (DictFunId _ _ _ _) = True
534 chk (ConstMethodId _ _ _ _ _) = True
535 chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
536 chk (InstId _ no_free_tvs) = no_free_tvs
537 chk (SpecId _ _ no_free_tvs) = no_free_tvs
538 chk (LocalId _ no_free_tvs) = no_free_tvs
539 chk (SysLocalId _ no_free_tvs) = no_free_tvs
540 chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
544 isTopLevId (Id _ _ (TopLevId _) _ _) = True
545 isTopLevId other = False
547 isImportedId (Id _ _ (ImportedId _) _ _) = True
548 isImportedId other = False
550 isBottomingId (Id _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
552 isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
553 isSysLocalId other = False
555 isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True
556 isSpecPragmaId other = False
558 isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True
559 isMethodSelId _ = False
561 isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True
562 isDefaultMethodId other = False
564 isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _)
565 = Just (cls, clsop, err)
566 isDefaultMethodId_maybe other = Nothing
568 isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True
569 isDictFunId other = False
571 isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True
572 isConstMethodId other = False
574 isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _)
575 = Just (cls, ty, clsop)
576 isConstMethodId_maybe other = Nothing
578 isSuperDictSelId_maybe (Id _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
579 isSuperDictSelId_maybe other_id = Nothing
581 isWorkerId (Id _ _ (WorkerId _) _ _) = True
582 isWorkerId other = False
585 isWrapperId id = workerExists (getIdStrictness id)
591 pprIdInUnfolding :: IdSet -> Id -> Pretty
593 pprIdInUnfolding in_scopes v
598 if v `elementOfUniqSet` in_scopes then
599 pprUnique (idUnique v)
601 -- ubiquitous Ids with special syntax:
602 else if v == nilDataCon then
604 else if isTupleCon v then
605 ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
607 -- ones to think about:
610 (Id _ _ v_details _ _) = v
613 -- these ones must have been exported by their original module
614 ImportedId _ -> pp_full_name
615 PreludeId _ -> pp_full_name
617 -- these ones' exportedness checked later...
618 TopLevId _ -> pp_full_name
619 DataConId _ _ _ _ _ _ _ _ -> pp_full_name
621 RecordSelId lbl -> ppr sty lbl
623 -- class-ish things: class already recorded as "mentioned"
625 -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
627 -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
628 DefaultMethodId c o _
629 -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
631 -- instance-ish things: should we try to figure out
632 -- *exactly* which extra instances have to be exported? (ToDo)
634 -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
635 ConstMethodId c t o _ _
636 -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
638 -- specialisations and workers
639 SpecId unspec ty_maybes _
641 pp = pprIdInUnfolding in_scopes unspec
643 ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
644 ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
649 pp = pprIdInUnfolding in_scopes unwrkr
651 ppBeside (ppPStr SLIT("_WRKR_ ")) pp
653 -- anything else? we're nae interested
654 other_id -> panic "pprIdInUnfolding:mystery Id"
656 ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
660 (m_str, n_str) = moduleNamePair v
663 if isLexSym n_str && not (isLexSpecialSym n_str) then
664 ppBesides [ppLparen, ppPStr n_str, ppRparen]
668 if isPreludeDefined v then
671 ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
673 pp_class :: Class -> Pretty
674 pp_class_op :: ClassOp -> Pretty
675 pp_type :: Type -> Pretty
676 pp_ty_maybe :: Maybe Type -> Pretty
678 pp_class clas = ppr ppr_Unfolding clas
679 pp_class_op op = ppr ppr_Unfolding op
681 pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
683 pp_ty_maybe Nothing = ppPStr SLIT("_N_")
684 pp_ty_maybe (Just t) = pp_type t
688 @whatsMentionedInId@ ferrets out the types/classes/instances on which
689 this @Id@ depends. If this Id is to appear in an interface, then
690 those entities had Jolly Well be in scope. Someone else up the
691 call-tree decides that.
696 :: IdSet -- Ids known to be in scope
697 -> Id -- Id being processed
698 -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
700 whatsMentionedInId in_scopes v
705 = getMentionedTyConsAndClassesFromType v_ty
707 result0 id_bag = (id_bag, tycons, clss)
710 = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
711 tcs `unionBags` tycons,
715 if v `elementOfUniqSet` in_scopes then
716 result0 emptyBag -- v not added to "mentioned"
718 -- ones to think about:
721 (Id _ _ v_details _ _) = v
724 -- specialisations and workers
725 SpecId unspec ty_maybes _
727 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
729 result1 ids2 tcs2 cs2
733 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
735 result1 ids2 tcs2 cs2
737 anything_else -> result0 (unitBag v) -- v is added to "mentioned"
741 Tell them who my wrapper function is.
744 myWrapperMaybe :: Id -> Maybe Id
746 myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
747 myWrapperMaybe other_id = Nothing
752 unfoldingUnfriendlyId -- return True iff it is definitely a bad
753 :: Id -- idea to export an unfolding that
754 -> Bool -- mentions this Id. Reason: it cannot
755 -- possibly be seen in another module.
757 unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
760 unfoldingUnfriendlyId id
761 | not (externallyVisibleId id) -- that settles that...
764 unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _)
765 = class_thing wrapper
767 -- "class thing": If we're going to use this worker Id in
768 -- an interface, we *have* to be able to untangle the wrapper's
769 -- strictness when reading it back in. At the moment, this
770 -- is not always possible: in precisely those cases where
771 -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
773 class_thing (Id _ _ (SuperDictSelId _ _) _ _) = True
774 class_thing (Id _ _ (MethodSelId _ _) _ _) = True
775 class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True
776 class_thing other = False
778 unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _)
779 -- a SPEC of a DictFunId can end up w/ gratuitous
780 -- TyVar(Templates) in the i/face; only a problem
781 -- if -fshow-pragma-name-errs; but we can do without the pain.
782 -- A HACK in any case (WDP 94/05/02)
783 = naughty_DictFunId dfun
785 unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
786 = naughty_DictFunId dfun -- similar deal...
788 unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
790 naughty_DictFunId :: IdDetails -> Bool
791 -- True <=> has a TyVar(Template) in the "type" part of its "name"
793 naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
794 naughty_DictFunId (DictFunId _ ty _ _)
795 = not (isGroundTy ty)
799 @externallyVisibleId@: is it true that another module might be
800 able to ``see'' this Id?
802 We need the @toplevelishId@ check as well as @isExported@ for when we
803 compile instance declarations in the prelude. @DictFunIds@ are
804 ``exported'' if either their class or tycon is exported, but, in
805 compiling the prelude, the compiler may not recognise that as true.
808 externallyVisibleId :: Id -> Bool
810 externallyVisibleId id@(Id _ _ details _ _)
811 = if isLocallyDefined id then
812 toplevelishId id && isExported id && not (weird_datacon details)
814 not (weird_tuplecon details)
815 -- if visible here, it must be visible elsewhere, too.
817 -- If it's a DataCon, it's not enough to know it (meaning
818 -- its TyCon) is exported; we need to know that it might
819 -- be visible outside. Consider:
821 -- data Foo a = Mumble | BigFoo a WeirdLocalType
823 -- We can't tell the outside world *anything* about Foo, because
824 -- of WeirdLocalType; but we need to know this when asked if
825 -- "Mumble" is externally visible...
828 weird_datacon (DataConId _ _ _ _ _ _ _ tycon)
829 = maybeToBool (maybePurelyLocalTyCon tycon)
831 weird_datacon not_a_datacon_therefore_not_weird = False
833 weird_tuplecon (TupleConId _ arity)
834 = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
835 weird_tuplecon _ = False
839 idWantsToBeINLINEd :: Id -> Bool
841 idWantsToBeINLINEd (Id _ _ _ IWantToBeINLINEd _) = True
842 idWantsToBeINLINEd _ = False
845 For @unlocaliseId@: See the brief commentary in
846 \tr{simplStg/SimplStg.lhs}.
850 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
852 unlocaliseId mod (Id u ty info (TopLevId fn))
853 = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
855 unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
856 = --false?: ASSERT(no_ftvs)
858 full_name = unlocaliseShortName mod u sn
860 Just (Id u ty info (TopLevId full_name))
862 unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
863 = --false?: on PreludeGlaST: ASSERT(no_ftvs)
865 full_name = unlocaliseShortName mod u sn
867 Just (Id u ty info (TopLevId full_name))
869 unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
870 = case unlocalise_parent mod u unspec of
872 Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))
874 unlocaliseId mod (Id u ty info (WorkerId unwrkr))
875 = case unlocalise_parent mod u unwrkr of
877 Just xx -> Just (Id u ty info (WorkerId xx))
879 unlocaliseId mod (Id u ty info (InstId name no_ftvs))
880 = Just (Id u ty info (TopLevId full_name))
881 -- type might be wrong, but it hardly matters
882 -- at this stage (just before printing C) ToDo
884 name = getLocalName name
885 full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
887 unlocaliseId mod other_id = Nothing
890 -- we have to be Very Careful for workers/specs of
893 unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs))
894 = --false?: ASSERT(no_ftvs)
896 full_name = unlocaliseShortName mod uniq sn
898 Just (Id uniq ty info (TopLevId full_name))
900 unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
901 = --false?: ASSERT(no_ftvs)
903 full_name = unlocaliseShortName mod uniq sn
905 Just (Id uniq ty info (TopLevId full_name))
907 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
908 -- we're OK otherwise
912 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
913 `Top-levelish Ids'' cannot have any free type variables, so applying
914 the type-env cannot have any effect. (NB: checked in CoreLint?)
916 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
917 former ``should be'' the usual crunch point.
920 type TypeEnv = TyVarEnv Type
922 applyTypeEnvToId :: TypeEnv -> Id -> Id
924 applyTypeEnvToId type_env id@(Id _ ty _ _ _)
925 | idHasNoFreeTyVars id
928 = apply_to_Id ( \ ty ->
929 applyTypeEnvToTy type_env ty
934 apply_to_Id :: (Type -> Type)
938 apply_to_Id ty_fn (Id u ty details prag info)
942 Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
944 apply_to_details (SpecId unspec ty_maybes no_ftvs)
946 new_unspec = apply_to_Id ty_fn unspec
947 new_maybes = map apply_to_maybe ty_maybes
949 SpecId new_unspec new_maybes (no_free_tvs ty)
950 -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
952 apply_to_maybe Nothing = Nothing
953 apply_to_maybe (Just ty) = Just (ty_fn ty)
955 apply_to_details (WorkerId unwrkr)
957 new_unwrkr = apply_to_Id ty_fn unwrkr
961 apply_to_details other = other
964 Sadly, I don't think the one using the magic typechecker substitution
965 can be done with @apply_to_Id@. Here we go....
967 Strictness is very important here. We can't leave behind thunks
968 with pointers to the substitution: it {\em must} be single-threaded.
972 applySubstToId :: Subst -> Id -> (Subst, Id)
974 applySubstToId subst id@(Id u ty info details)
975 -- *cannot* have a "idHasNoFreeTyVars" get-out clause
976 -- because, in the typechecker, we are still
977 -- *concocting* the types.
978 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
979 case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
980 case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
981 (s4, Id u new_ty new_info new_details) }}}
983 apply_to_details subst _ (InstId inst no_ftvs)
984 = case (applySubstToInst subst inst) of { (s2, new_inst) ->
985 (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
987 apply_to_details subst new_ty (SpecId unspec ty_maybes _)
988 = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
989 case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
990 (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
991 -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
993 apply_to_maybe subst Nothing = (subst, Nothing)
994 apply_to_maybe subst (Just ty)
995 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
998 apply_to_details subst _ (WorkerId unwrkr)
999 = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
1000 (s2, WorkerId new_unwrkr) }
1002 apply_to_details subst _ other = (subst, other)
1007 getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
1009 getIdNamePieces show_uniqs id
1010 = get (unsafeGenId2Id id)
1012 get (Id u _ details _ _)
1014 DataConId n _ _ _ _ _ _ _ ->
1015 case (moduleNamePair n) of { (mod, name) ->
1016 if isPreludeDefinedName n then [name] else [mod, name] }
1018 TupleConId n _ -> [nameOf (origName n)]
1021 let n = fieldLabelName lbl
1023 case (moduleNamePair n) of { (mod, name) ->
1024 if isPreludeDefinedName n then [name] else [mod, name] }
1026 ImportedId n -> get_fullname_pieces n
1027 PreludeId n -> get_fullname_pieces n
1028 TopLevId n -> get_fullname_pieces n
1030 SuperDictSelId c sc ->
1031 case (moduleNamePair c) of { (c_mod, c_name) ->
1032 case (moduleNamePair sc) of { (sc_mod, sc_name) ->
1034 c_bits = if isPreludeDefined c
1036 else [c_mod, c_name]
1038 sc_bits= if isPreludeDefined sc
1040 else [sc_mod, sc_name]
1042 [SLIT("sdsel")] ++ c_bits ++ sc_bits }}
1044 MethodSelId clas op ->
1045 case (moduleNamePair clas) of { (c_mod, c_name) ->
1046 case (classOpString op) of { op_name ->
1047 if isPreludeDefined clas
1049 else [c_mod, c_name, op_name]
1052 DefaultMethodId clas op _ ->
1053 case (moduleNamePair clas) of { (c_mod, c_name) ->
1054 case (classOpString op) of { op_name ->
1055 if isPreludeDefined clas
1056 then [SLIT("defm"), op_name]
1057 else [SLIT("defm"), c_mod, c_name, op_name] }}
1059 DictFunId c ty _ _ ->
1060 case (moduleNamePair c) of { (c_mod, c_name) ->
1062 c_bits = if isPreludeDefined c
1064 else [c_mod, c_name]
1066 ty_bits = getTypeString ty
1068 [SLIT("dfun")] ++ c_bits ++ ty_bits }
1070 ConstMethodId c ty o _ _ ->
1071 case (moduleNamePair c) of { (c_mod, c_name) ->
1072 case (getTypeString ty) of { ty_bits ->
1073 case (classOpString o) of { o_name ->
1074 case (if isPreludeDefined c
1076 else [c_mod, c_name]) of { c_bits ->
1077 [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
1079 -- if the unspecialised equiv is "top-level",
1080 -- the name must be concocted from its name and the
1081 -- names of the types to which specialised...
1083 SpecId unspec ty_maybes _ ->
1084 get unspec ++ (if not (toplevelishId unspec)
1086 else concat (map typeMaybeString ty_maybes))
1089 get unwrkr ++ (if not (toplevelishId unwrkr)
1093 LocalId n _ -> let local = getLocalName n in
1094 if show_uniqs then [local, showUnique u] else [local]
1095 InstId n _ -> [getLocalName n, showUnique u]
1096 SysLocalId n _ -> [getLocalName n, showUnique u]
1097 SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
1099 get_fullname_pieces :: Name -> [FAST_STRING]
1100 get_fullname_pieces n
1101 = BIND (moduleNamePair n) _TO_ (mod, name) ->
1102 if isPreludeDefinedName n
1108 %************************************************************************
1110 \subsection[Id-type-funs]{Type-related @Id@ functions}
1112 %************************************************************************
1115 idType :: GenId ty -> ty
1117 idType (Id _ ty _ _ _) = ty
1122 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1124 getMentionedTyConsAndClassesFromId id
1125 = getMentionedTyConsAndClassesFromType (idType id)
1130 idPrimRep i = typePrimRep (idType i)
1135 getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
1136 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
1137 getInstIdModule other = panic "Id:getInstIdModule"
1141 %************************************************************************
1143 \subsection[Id-overloading]{Functions related to overloading}
1145 %************************************************************************
1148 mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
1149 mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
1150 mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
1152 mkDictFunId u c ity full_ty from_here mod info
1153 = Id u full_ty (DictFunId c ity from_here mod) NoPragmaInfo info
1155 mkConstMethodId u c op ity full_ty from_here mod info
1156 = Id u full_ty (ConstMethodId c ity op from_here mod) NoPragmaInfo info
1158 mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
1160 mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo
1163 getConstMethodId clas op ty
1164 = -- constant-method info is hidden in the IdInfo of
1165 -- the class-op id (as mentioned up above).
1167 sel_id = getMethodSelId clas op
1169 case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1171 Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
1172 ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1173 ppr PprDebug sel_id],
1174 ppStr "(This can arise if an interface pragma refers to an instance",
1175 ppStr "but there is no imported interface which *defines* that instance.",
1176 ppStr "The info above, however ugly, should indicate what else you need to import."
1181 %************************************************************************
1183 \subsection[local-funs]{@LocalId@-related functions}
1185 %************************************************************************
1188 mkImported n ty info = Id (nameUnique n) ty (ImportedId n) NoPragmaInfo info
1189 mkPreludeId n ty info = Id (nameUnique n) ty (PreludeId n) NoPragmaInfo info
1192 updateIdType :: Id -> Type -> Id
1193 updateIdType (Id u _ info details) ty = Id u ty info details
1198 type MyTy a b = GenType (GenTyVar a) b
1199 type MyId a b = GenId (MyTy a b)
1201 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1203 -- SysLocal: for an Id being created by the compiler out of thin air...
1204 -- UserLocal: an Id with a name the user might recognize...
1205 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1207 mkSysLocal str uniq ty loc
1208 = Id uniq ty (SysLocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1210 mkUserLocal str uniq ty loc
1211 = Id uniq ty (LocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1213 -- mkUserId builds a local or top-level Id, depending on the name given
1214 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1215 mkUserId name ty pragma_info
1217 = Id (nameUnique name) ty (LocalId name (no_free_tvs ty)) pragma_info noIdInfo
1219 = Id (nameUnique name) ty
1220 (if isLocallyDefinedName name then TopLevId name else ImportedId name)
1221 pragma_info noIdInfo
1228 -- for a SpecPragmaId being created by the compiler out of thin air...
1229 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1230 mkSpecPragmaId str uniq ty specid loc
1231 = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
1234 mkSpecId u unspec ty_maybes ty info
1235 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1236 Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1238 -- Specialised version of constructor: only used in STG and code generation
1239 -- Note: The specialsied Id has the same unique as the unspeced Id
1241 mkSameSpecCon ty_maybes unspec@(Id u ty info details)
1242 = ASSERT(isDataCon unspec)
1243 ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1244 Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1246 new_ty = specialiseTy ty ty_maybes 0
1248 localiseId :: Id -> Id
1249 localiseId id@(Id u ty info details)
1250 = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
1252 name = getOccName id
1256 mkIdWithNewUniq :: Id -> Unique -> Id
1258 mkIdWithNewUniq (Id _ ty details prag info) uniq
1259 = Id uniq ty details prag info
1262 Make some local @Ids@ for a template @CoreExpr@. These have bogus
1263 @Uniques@, but that's OK because the templates are supposed to be
1264 instantiated before use.
1266 mkTemplateLocals :: [Type] -> [Id]
1267 mkTemplateLocals tys
1268 = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1269 (getBuiltinUniques (length tys))
1274 getIdInfo :: GenId ty -> IdInfo
1275 getPragmaInfo :: GenId ty -> PragmaInfo
1277 getIdInfo (Id _ _ _ _ info) = info
1278 getPragmaInfo (Id _ _ _ info _) = info
1281 replaceIdInfo :: Id -> IdInfo -> Id
1283 replaceIdInfo (Id u ty _ details) info = Id u ty info details
1285 selectIdInfoForSpecId :: Id -> IdInfo
1286 selectIdInfoForSpecId unspec
1287 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1288 noIdInfo `addInfo_UF` getIdUnfolding unspec
1292 %************************************************************************
1294 \subsection[Id-arities]{Arity-related functions}
1296 %************************************************************************
1298 For locally-defined Ids, the code generator maintains its own notion
1299 of their arities; so it should not be asking... (but other things
1300 besides the code-generator need arity info!)
1303 getIdArity :: Id -> ArityInfo
1304 getIdArity (Id _ _ _ _ id_info) = getInfo id_info
1306 dataConArity :: DataCon -> Int
1307 dataConArity id@(Id _ _ _ _ id_info)
1308 = ASSERT(isDataCon id)
1309 case (arityMaybe (getInfo id_info)) of
1310 Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1313 addIdArity :: Id -> Int -> Id
1314 addIdArity (Id u ty details pinfo info) arity
1315 = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
1318 %************************************************************************
1320 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1322 %************************************************************************
1326 -> [StrictnessMark] -> [FieldLabel]
1327 -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1330 -- can get the tag and all the pieces of the type from the Type
1332 mkDataCon n stricts fields tvs ctxt args_tys tycon
1333 = ASSERT(length stricts == length args_tys)
1336 -- NB: data_con self-recursion; should be OK as tags are not
1337 -- looked at until late in the game.
1341 (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon)
1345 data_con_tag = position_within fIRST_TAG data_con_family
1347 data_con_family = tyConDataCons tycon
1349 position_within :: Int -> [Id] -> Int
1351 position_within acc (c:cs)
1352 = if c == data_con then acc else position_within (acc+1) cs
1354 position_within acc []
1355 = panic "mkDataCon: con not found in family"
1359 = mkSigmaTy tvs ctxt
1360 (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1362 datacon_info = noIdInfo `addInfo_UF` unfolding
1363 `addInfo` mkArityInfo arity
1364 --ToDo: `addInfo` specenv
1366 arity = length args_tys
1373 -- else -- do some business...
1375 (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1376 tyvar_tys = mkTyVarTys tyvars
1378 BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1380 mkUnfolding EssentialUnfolding -- for data constructors
1381 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1384 mk_uf_bits tvs ctxt arg_tys tycon
1386 (inst_env, tyvars, tyvar_tys)
1387 = instantiateTyVarTemplates tvs
1390 -- the "context" and "arg_tys" have TyVarTemplates in them, so
1391 -- we instantiate those types to have the right TyVars in them
1393 BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1394 _TO_ inst_dict_tys ->
1395 BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys ->
1397 -- We can only have **ONE** call to mkTemplateLocals here;
1398 -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1399 -- (Mega-Sigh) [ToDo]
1400 BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
1402 BIND (splitAt (length ctxt) all_vars) _TO_ (dict_vars, vars) ->
1404 (tyvars, dict_vars, vars)
1407 -- these are really dubious Types, but they are only to make the
1408 -- binders for the lambdas for tossed-away dicts.
1409 ctxt_ty (clas, ty) = mkDictTy clas ty
1414 mkTupleCon :: Arity -> Id
1417 = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info
1419 n = mkTupleDataConName arity
1421 ty = mkSigmaTy tyvars []
1422 (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1423 tycon = mkTupleTyCon arity
1424 tyvars = take arity alphaTyVars
1425 tyvar_tys = mkTyVarTys tyvars
1428 = noIdInfo `addInfo_UF` unfolding
1429 `addInfo` mkArityInfo arity
1430 --LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1437 -- else -- do some business...
1439 (tyvars, dict_vars, vars) = mk_uf_bits arity
1440 tyvar_tys = mkTyVarTys tyvars
1442 BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1445 EssentialUnfolding -- data constructors
1446 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1450 = BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
1454 tyvar_tmpls = take arity alphaTyVars
1455 (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
1459 fIRST_TAG = 1 -- Tags allocated from here for real constructors
1463 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1464 dataConTag (Id _ _ (DataConId _ tag _ _ _ _ _ _) _ _) = tag
1465 dataConTag (Id _ _ (TupleConId _ _) _ _) = fIRST_TAG
1466 dataConTag (Id _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
1468 dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
1469 dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon
1470 dataConTyCon (Id _ _ (TupleConId _ a) _ _) = mkTupleTyCon a
1472 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1473 -- will panic if not a DataCon
1475 dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1476 = (tyvars, theta_ty, arg_tys, tycon)
1478 dataConSig (Id _ _ (TupleConId _ arity) _ _)
1479 = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1481 tyvars = take arity alphaTyVars
1482 tyvar_tys = mkTyVarTys tyvars
1484 dataConFieldLabels :: DataCon -> [FieldLabel]
1485 dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields
1486 dataConFieldLabels (Id _ _ (TupleConId _ _) _ _) = []
1488 dataConStrictMarks :: DataCon -> [StrictnessMark]
1489 dataConStrictMarks (Id _ _ (DataConId _ _ stricts _ _ _ _ _) _ _) = stricts
1490 dataConStrictMarks (Id _ _ (TupleConId _ arity) _ _)
1491 = take arity (repeat NotMarkedStrict)
1493 dataConArgTys :: DataCon
1494 -> [Type] -- Instantiated at these types
1495 -> [Type] -- Needs arguments of these types
1496 dataConArgTys con_id inst_tys
1497 = map (instantiateTy tenv) arg_tys
1499 (tyvars, _, arg_tys, _) = dataConSig con_id
1500 tenv = tyvars `zipEqual` inst_tys
1504 mkRecordSelId field_label selector_ty
1505 = Id (nameUnique name)
1507 (RecordSelId field_label)
1511 name = fieldLabelName field_label
1513 recordSelectorFieldLabel :: Id -> FieldLabel
1514 recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl
1518 Data type declarations are of the form:
1520 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1522 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1523 @C1 x y z@, we want a function binding:
1525 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1527 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1528 2nd-order polymorphic lambda calculus with explicit types.
1530 %************************************************************************
1532 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1534 %************************************************************************
1536 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1537 and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
1538 @TyVars@ don't really have to be new, because we are only producing a
1541 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1544 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1545 EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the
1546 example above: a, b, and x, y, z], which is enough (in the important
1547 \tr{DsExpr} case). (The middle set of @Ids@ is binders for any
1548 dictionaries, in the even of an overloaded data-constructor---none at
1552 getIdUnfolding :: Id -> UnfoldingDetails
1554 getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info
1557 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1558 addIdUnfolding id@(Id u ty info details) unfold_details
1560 case (isLocallyDefined id, unfold_details) of
1561 (_, NoUnfoldingDetails) -> True
1562 (True, IWantToBeINLINEd _) -> True
1563 (False, IWantToBeINLINEd _) -> False -- v bad
1567 Id u ty (info `addInfo_UF` unfold_details) details
1571 In generating selector functions (take a dictionary, give back one
1572 component...), we need to what out for the nothing-to-select cases (in
1573 which case the ``selector'' is just an identity function):
1575 class Eq a => Foo a { } # the superdict selector for "Eq"
1577 class Foo a { op :: Complex b => c -> b -> a }
1578 # the method selector for "op";
1579 # note local polymorphism...
1582 %************************************************************************
1584 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1586 %************************************************************************
1589 getIdDemandInfo :: Id -> DemandInfo
1590 getIdDemandInfo (Id _ _ _ _ info) = getInfo info
1592 addIdDemandInfo :: Id -> DemandInfo -> Id
1593 addIdDemandInfo (Id u ty details prags info) demand_info
1594 = Id u ty details prags (info `addInfo` demand_info)
1598 getIdUpdateInfo :: Id -> UpdateInfo
1599 getIdUpdateInfo (Id _ _ _ _ info) = getInfo info
1601 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1602 addIdUpdateInfo (Id u ty details prags info) upd_info
1603 = Id u ty details prags (info `addInfo` upd_info)
1608 getIdArgUsageInfo :: Id -> ArgUsageInfo
1609 getIdArgUsageInfo (Id u ty info details) = getInfo info
1611 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1612 addIdArgUsageInfo (Id u ty info details) au_info
1613 = Id u ty (info `addInfo` au_info) details
1619 getIdFBTypeInfo :: Id -> FBTypeInfo
1620 getIdFBTypeInfo (Id u ty info details) = getInfo info
1622 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1623 addIdFBTypeInfo (Id u ty info details) upd_info
1624 = Id u ty (info `addInfo` upd_info) details
1630 getIdSpecialisation :: Id -> SpecEnv
1631 getIdSpecialisation (Id _ _ _ _ info) = getInfo info
1633 addIdSpecialisation :: Id -> SpecEnv -> Id
1634 addIdSpecialisation (Id u ty details prags info) spec_info
1635 = Id u ty details prags (info `addInfo` spec_info)
1639 Strictness: we snaffle the info out of the IdInfo.
1642 getIdStrictness :: Id -> StrictnessInfo
1644 getIdStrictness (Id _ _ _ _ info) = getInfo info
1646 addIdStrictness :: Id -> StrictnessInfo -> Id
1648 addIdStrictness (Id u ty details prags info) strict_info
1649 = Id u ty details prags (info `addInfo` strict_info)
1652 %************************************************************************
1654 \subsection[Id-comparison]{Comparison functions for @Id@s}
1656 %************************************************************************
1658 Comparison: equality and ordering---this stuff gets {\em hammered}.
1661 cmpId (Id u1 _ _ _ _) (Id u2 _ _ _ _) = cmp u1 u2
1662 -- short and very sweet
1666 instance Ord3 (GenId ty) where
1669 instance Eq (GenId ty) where
1670 a == b = case cmpId a b of { EQ_ -> True; _ -> False }
1671 a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
1673 instance Ord (GenId ty) where
1674 a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
1675 a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
1676 a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
1677 a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
1678 _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1681 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1682 account when comparing two data constructors. We need to do this
1683 because a specialised data constructor has the same Unique as its
1684 unspecialised counterpart.
1687 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1689 cmpId_withSpecDataCon id1 id2
1690 | eq_ids && isDataCon id1 && isDataCon id2
1691 = cmpEqDataCon id1 id2
1696 cmp_ids = cmpId id1 id2
1697 eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
1699 cmpEqDataCon (Id _ _ (SpecId _ mtys1 _) _ _) (Id _ _ (SpecId _ mtys2 _) _ _)
1700 = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1702 cmpEqDataCon _ (Id _ _ (SpecId _ _ _) _ _) = LT_
1703 cmpEqDataCon (Id _ _ (SpecId _ _ _) _ _) _ = GT_
1704 cmpEqDataCon _ _ = EQ_
1707 %************************************************************************
1709 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1711 %************************************************************************
1714 instance Outputable ty => Outputable (GenId ty) where
1715 ppr sty id = pprId sty id
1717 -- and a SPECIALIZEd one:
1718 instance Outputable {-Id, i.e.:-}(GenId Type) where
1719 ppr sty id = pprId sty id
1721 showId :: PprStyle -> Id -> String
1722 showId sty id = ppShow 80 (pprId sty id)
1725 -- for DictFuns (instances) and const methods (instance code bits we
1726 -- can call directly): exported (a) if *either* the class or
1727 -- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
1728 -- class and tycon are from PreludeCore [non-std, but convenient]
1729 -- *and* the thing was defined in this module.
1731 instance_export_flag :: Class -> Type -> Bool -> ExportFlag
1733 instance_export_flag clas inst_ty from_here
1734 = panic "Id:instance_export_flag"
1736 = if instanceIsExported clas inst_ty from_here
1742 Default printing code (not used for interfaces):
1744 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1748 pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
1752 pieces_to_print -- maybe use Unique only
1753 = if isSysLocalId id then tail pieces else pieces
1755 ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
1759 PprForAsm _ _ -> for_code
1760 PprInterface -> ppr other_sty occur_name
1761 PprForUser -> ppr other_sty occur_name
1762 PprUnfolding -> qualified_name pieces
1763 PprDebug -> qualified_name pieces
1764 PprShowAll -> ppBesides [qualified_name pieces,
1767 ppr other_sty (idType id),
1768 ppIdInfo other_sty (unsafeGenId2Id id) True
1769 (\x->x) nullIdEnv (getIdInfo id),
1770 ppPStr SLIT("-}") ])]
1772 occur_name = getOccName id `appendRdr`
1773 (if not (isSysLocalId id)
1775 else SLIT(".") _APPEND_ (showUnique (idUnique id)))
1777 qualified_name pieces
1778 = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
1780 pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add
1781 pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = ppNil
1782 pp_uniq (Id _ _ (TupleConId _ _) _ _) = ppNil
1783 pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere
1784 pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil
1785 pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil
1786 pp_uniq (Id _ _ (InstId _ _) _ _) = ppNil
1787 pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (idUnique other_id), ppPStr SLIT("-}")]
1789 -- print PprDebug Ids with # afterwards if they are of primitive type.
1790 pp_ubxd pretty = pretty
1792 {- LATER: applying isPrimType restricts type
1793 pp_ubxd pretty = if isPrimType (idType id)
1794 then ppBeside pretty (ppChar '#')
1801 idUnique (Id u _ _ _ _) = u
1803 instance Uniquable (GenId ty) where
1806 instance NamedThing (GenId ty) where
1807 getName this_id@(Id u _ details _ _)
1810 get (LocalId n _) = n
1811 get (SysLocalId n _) = n
1812 get (SpecPragmaId n _ _) = n
1813 get (ImportedId n) = n
1814 get (PreludeId n) = n
1815 get (TopLevId n) = n
1816 get (InstId n _) = n
1817 get (DataConId n _ _ _ _ _ _ _) = n
1818 get (TupleConId n _) = n
1819 get (RecordSelId l) = getName l
1820 get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id)
1823 get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ???
1824 mod -> (mod, classOpString op)
1826 get (SpecId unspec ty_maybes _)
1827 = BIND moduleNamePair unspec _TO_ (mod, unspec_nm) ->
1828 BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
1831 (if not (toplevelishId unspec)
1837 get (WorkerId unwrkr)
1838 = BIND moduleNamePair unwrkr _TO_ (mod, unwrkr_nm) ->
1841 (if not (toplevelishId unwrkr)
1848 -- the remaining internally-generated flavours of
1849 -- Ids really do not have meaningful "original name" stuff,
1850 -- but we need to make up something (usually for debugging output)
1852 = BIND (getIdNamePieces True this_id) _TO_ (piece1:pieces) ->
1853 BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
1854 (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
1859 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1860 the @Uniques@ out of local @Ids@ given to it.
1862 %************************************************************************
1864 \subsection{@IdEnv@s and @IdSet@s}
1866 %************************************************************************
1869 type IdEnv elt = UniqFM elt
1871 nullIdEnv :: IdEnv a
1873 mkIdEnv :: [(GenId ty, a)] -> IdEnv a
1874 unitIdEnv :: GenId ty -> a -> IdEnv a
1875 addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
1876 growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
1877 growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1879 delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
1880 delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
1881 combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1882 mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
1883 modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
1884 rngIdEnv :: IdEnv a -> [a]
1886 isNullIdEnv :: IdEnv a -> Bool
1887 lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
1888 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1892 addOneToIdEnv = addToUFM
1893 combineIdEnvs = plusUFM_C
1894 delManyFromIdEnv = delListFromUFM
1895 delOneFromIdEnv = delFromUFM
1897 lookupIdEnv = lookupUFM
1900 nullIdEnv = emptyUFM
1904 growIdEnvList env pairs = plusUFM env (listToUFM pairs)
1905 isNullIdEnv env = sizeUFM env == 0
1906 lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
1908 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1909 -- modify function, and put it back.
1911 modifyIdEnv env mangle_fn key
1912 = case (lookupIdEnv env key) of
1914 Just xx -> addOneToIdEnv env key (mangle_fn xx)
1918 type GenIdSet ty = UniqSet (GenId ty)
1919 type IdSet = UniqSet (GenId Type)
1921 emptyIdSet :: GenIdSet ty
1922 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1923 unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1924 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1925 idSetToList :: GenIdSet ty -> [GenId ty]
1926 unitIdSet :: GenId ty -> GenIdSet ty
1927 addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
1928 elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
1929 minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1930 isEmptyIdSet :: GenIdSet ty -> Bool
1931 mkIdSet :: [GenId ty] -> GenIdSet ty
1933 emptyIdSet = emptyUniqSet
1934 unitIdSet = unitUniqSet
1935 addOneToIdSet = addOneToUniqSet
1936 intersectIdSets = intersectUniqSets
1937 unionIdSets = unionUniqSets
1938 unionManyIdSets = unionManyUniqSets
1939 idSetToList = uniqSetToList
1940 elementOfIdSet = elementOfUniqSet
1941 minusIdSet = minusUniqSet
1942 isEmptyIdSet = isEmptyUniqSet
1947 addId, nmbrId :: Id -> NmbrM Id
1949 addId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1950 = case (lookupUFM_Directly idenv u) of
1951 Just xx -> _trace "addId: already in map!" $
1954 if toplevelishId id then
1955 _trace "addId: can't add toplevelish!" $
1957 else -- alloc a new unique for this guy
1958 -- and add an entry in the idenv
1959 -- NB: *** KNOT-TYING ***
1961 nenv_plus_id = NmbrEnv (incrUnique ui) ut uu
1962 (addToUFM_Directly idenv u new_id)
1965 (nenv2, new_ty) = nmbrType ty nenv_plus_id
1966 (nenv3, new_det) = nmbr_details det nenv2
1968 new_id = Id ui new_ty new_det prag info
1972 nmbrId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1973 = case (lookupUFM_Directly idenv u) of
1974 Just xx -> (nenv, xx)
1976 if not (toplevelishId id) then
1977 _trace "nmbrId: lookup failed" $
1981 (nenv2, new_ty) = nmbrType ty nenv
1982 (nenv3, new_det) = nmbr_details det nenv2
1984 new_id = Id u new_ty new_det prag info
1989 nmbr_details :: IdDetails -> NmbrM IdDetails
1991 nmbr_details (DataConId n tag marks fields tvs theta arg_tys tc)
1992 = mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
1993 mapNmbr nmbrField fields `thenNmbr` \ new_fields ->
1994 mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
1995 mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys ->
1996 returnNmbr (DataConId n tag marks new_fields new_tvs new_theta new_arg_tys tc)
1999 = --nmbrClass c `thenNmbr` \ new_c ->
2000 nmbrType t `thenNmbr` \ new_t ->
2001 returnNmbr (c, new_t)
2003 -- ToDo:add more cases as needed
2004 nmbr_details other_details = returnNmbr other_details
2007 nmbrField (FieldLabel n ty tag)
2008 = nmbrType ty `thenNmbr` \ new_ty ->
2009 returnNmbr (FieldLabel n new_ty tag)