2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[Id]{@Ids@: Value and constructor identifiers}
7 #include "HsVersions.h"
11 GenId(..), -- *naughtily* used in some places (e.g., TcHsSyn)
12 SYN_IE(Id), IdDetails,
14 SYN_IE(ConTag), fIRST_TAG,
15 SYN_IE(DataCon), SYN_IE(DictFun), SYN_IE(DictVar),
38 -- DESTRUCTION (excluding pragmatic info)
53 recordSelectorFieldLabel,
58 cmpId_withSpecDataCon,
64 isConstMethodId_maybe,
67 isDefaultMethodId_maybe,
73 isSuperDictSelId_maybe,
80 unfoldingUnfriendlyId,
86 -- PRINTING and RENUMBERING
93 -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
108 SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
138 IMPORT_DELOOPER(IdLoop) -- for paranoia checking
139 IMPORT_DELOOPER(TyLoop) -- for paranoia checking
142 import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp )
144 import Maybes ( maybeToBool )
145 import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
146 isLocallyDefinedName,
147 mkTupleDataConName, mkCompoundName, mkCompoundName2,
148 isLexSym, isLexSpecialSym,
149 isLocallyDefined, changeUnique,
150 getOccName, origName, moduleOf,
151 isExported, ExportFlag(..),
154 import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
155 import PragmaInfo ( PragmaInfo(..) )
156 import PprEnv -- ( SYN_IE(NmbrM), NmbrEnv(..) )
157 import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
163 import SrcLoc ( mkBuiltinSrcLoc )
164 import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
165 import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
166 applyTyCon, instantiateTy,
167 tyVarsOfType, applyTypeEnvToTy, typePrimRep,
168 GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type)
170 import TyVar ( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) )
172 import UniqSet -- practically all of it
173 import Unique ( getBuiltinUniques, pprUnique, showUnique,
175 Unique{-instance Ord3-}
177 import Util ( mapAccumL, nOfThem, zipEqual,
178 panic, panic#, pprPanic, assertPanic
182 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
185 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
186 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
187 strictness). The essential info about different kinds of @Ids@ is
190 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
194 Unique -- Key for fast comparison
196 ty -- Id's type; used all the time;
197 IdDetails -- Stuff about individual kinds of Ids.
198 PragmaInfo -- Properties of this Id requested by programmer
199 -- eg specialise-me, inline-me
200 IdInfo -- Properties of this Id deduced by compiler
204 data StrictnessMark = MarkedStrict | NotMarkedStrict
208 ---------------- Local values
210 = LocalId Bool -- Local name; mentioned by the user
211 -- True <=> no free type vars
213 | SysLocalId Bool -- Local name; made up by the compiler
216 | SpecPragmaId -- Local name; introduced by the compiler
217 (Maybe Id) -- for explicit specid in pragma
218 Bool -- as for LocalId
220 ---------------- Global values
222 | ImportedId -- Global name (Imported or Implicit); Id imported from an interface
224 | TopLevId -- Global name (LocalDef); Top-level in the orig source pgm
225 -- (not moved there by transformations).
227 -- a TopLevId's type may contain free type variables, if
228 -- the monomorphism restriction applies.
230 ---------------- Data constructors
233 [StrictnessMark] -- Strict args; length = arity
234 [FieldLabel] -- Field labels for this constructor
236 [TyVar] [(Class,Type)] [Type] TyCon
238 -- forall tyvars . theta_ty =>
239 -- unitype_1 -> ... -> unitype_n -> tycon tyvars
241 | TupleConId Int -- Its arity
243 | RecordSelId FieldLabel
245 ---------------- Things to do with overloading
247 | SuperDictSelId -- Selector for superclass dictionary
248 Class -- The class (input dict)
249 Class -- The superclass (result dict)
251 | MethodSelId Class -- An overloaded class operation, with
252 -- a fully polymorphic type. Its code
253 -- just selects a method from the
254 -- dictionary. The class.
255 ClassOp -- The operation
257 -- NB: The IdInfo for a MethodSelId has all the info about its
258 -- related "constant method Ids", which are just
259 -- specialisations of this general one.
261 | DefaultMethodId -- Default method for a particular class op
262 Class -- same class, <blah-blah> info as MethodSelId
263 ClassOp -- (surprise, surprise)
264 Bool -- True <=> I *know* this default method Id
265 -- is a generated one that just says
266 -- `error "No default method for <op>"'.
269 | DictFunId Class -- A DictFun is uniquely identified
270 Type -- by its class and type; this type has free type vars,
271 -- whose identity is irrelevant. Eg Class = Eq
273 -- The "a" is irrelevant. As it is too painful to
274 -- actually do comparisons that way, we kindly supply
275 -- a Unique for that purpose.
276 Module -- module where instance came from
279 | ConstMethodId -- A method which depends only on the type of the
280 -- instance, and not on any further dictionaries etc.
281 Class -- Uniquely identified by:
282 Type -- (class, type, classop) triple
284 Module -- module where instance came from
286 | InstId -- An instance of a dictionary, class operation,
287 -- or overloaded value (Local name)
288 Bool -- as for LocalId
290 | SpecId -- A specialisation of another Id
291 Id -- Id of which this is a specialisation
292 [Maybe Type] -- Types at which it is specialised;
293 -- A "Nothing" says this type ain't relevant.
294 Bool -- True <=> no free type vars; it's not enough
295 -- to know about the unspec version, because
296 -- we may specialise to a type w/ free tyvars
297 -- (i.e., in one of the "Maybe Type" dudes).
299 | WorkerId -- A "worker" for some other Id
300 Id -- Id for which this is a worker
308 DictFunIds are generated from instance decls.
313 instance Foo a => Foo [a] where
316 generates the dict fun id decl
318 dfun.Foo.[*] = \d -> ...
320 The dfun id is uniquely named by the (class, type) pair. Notice, it
321 isn't a (class,tycon) pair any more, because we may get manually or
322 automatically generated specialisations of the instance decl:
324 instance Foo [Int] where
331 The type variables in the name are irrelevant; we print them as stars.
334 Constant method ids are generated from instance decls where
335 there is no context; that is, no dictionaries are needed to
336 construct the method. Example
338 instance Foo Int where
341 Then we get a constant method
346 It is possible, albeit unusual, to have a constant method
347 for an instance decl which has type vars:
349 instance Foo [a] where
353 We get the constant method
357 So a constant method is identified by a class/op/type triple.
358 The type variables in the type are irrelevant.
361 For Ids whose names must be known/deducible in other modules, we have
362 to conjure up their worker's names (and their worker's worker's
363 names... etc) in a known systematic way.
366 %************************************************************************
368 \subsection[Id-documentation]{Documentation}
370 %************************************************************************
374 The @Id@ datatype describes {\em values}. The basic things we want to
375 know: (1)~a value's {\em type} (@idType@ is a very common
376 operation in the compiler); and (2)~what ``flavour'' of value it might
377 be---for example, it can be terribly useful to know that a value is a
381 %----------------------------------------------------------------------
382 \item[@DataConId@:] For the data constructors declared by a @data@
383 declaration. Their type is kept in {\em two} forms---as a regular
384 @Type@ (in the usual place), and also in its constituent pieces (in
385 the ``details''). We are frequently interested in those pieces.
387 %----------------------------------------------------------------------
388 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
389 the infinite family of tuples.
391 %----------------------------------------------------------------------
392 \item[@ImportedId@:] These are values defined outside this module.
393 {\em Everything} we want to know about them must be stored here (or in
396 %----------------------------------------------------------------------
397 \item[@TopLevId@:] These are values defined at the top-level in this
398 module; i.e., those which {\em might} be exported (hence, a
399 @Name@). It does {\em not} include those which are moved to the
400 top-level through program transformations.
402 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
403 Theoretically, they could be floated inwards, but there's no known
404 advantage in doing so. This way, we can keep them with the same
405 @Unique@ throughout (no cloning), and, in general, we don't have to be
406 so paranoid about them.
408 In particular, we had the following problem generating an interface:
409 We have to ``stitch together'' info (1)~from the typechecker-produced
410 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
411 what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change}
412 between (1) and (2), you're sunk!
414 %----------------------------------------------------------------------
415 \item[@MethodSelId@:] A selector from a dictionary; it may select either
416 a method or a dictionary for one of the class's superclasses.
418 %----------------------------------------------------------------------
421 @mkDictFunId [a,b..] theta C T@ is the function derived from the
424 instance theta => C (T a b ..) where
427 It builds function @Id@ which maps dictionaries for theta,
428 to a dictionary for C (T a b ..).
430 *Note* that with the ``Mark Jones optimisation'', the theta may
431 include dictionaries for the immediate superclasses of C at the type
434 %----------------------------------------------------------------------
437 %----------------------------------------------------------------------
440 %----------------------------------------------------------------------
443 %----------------------------------------------------------------------
444 \item[@LocalId@:] A purely-local value, e.g., a function argument,
445 something defined in a @where@ clauses, ... --- but which appears in
446 the original program text.
448 %----------------------------------------------------------------------
449 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
450 the original program text; these are introduced by the compiler in
453 %----------------------------------------------------------------------
454 \item[@SpecPragmaId@:] Introduced by the compiler to record
455 Specialisation pragmas. It is dead code which MUST NOT be removed
456 before specialisation.
461 %----------------------------------------------------------------------
464 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
465 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
469 They have no free type variables, so if you are making a
470 type-variable substitution you don't need to look inside them.
472 They are constants, so they are not free variables. (When the STG
473 machine makes a closure, it puts all the free variables in the
474 closure; the above are not required.)
476 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
477 properties, but they may not.
480 %************************************************************************
482 \subsection[Id-general-funs]{General @Id@-related functions}
484 %************************************************************************
487 unsafeGenId2Id :: GenId ty -> Id
488 unsafeGenId2Id (Id u n ty d p i) = Id u n (panic "unsafeGenId2Id:ty") d p i
490 isDataCon id = is_data (unsafeGenId2Id id)
492 is_data (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
493 is_data (Id _ _ _ (TupleConId _) _ _) = True
494 is_data (Id _ _ _ (SpecId unspec _ _) _ _) = is_data unspec
495 is_data other = False
498 isTupleCon id = is_tuple (unsafeGenId2Id id)
500 is_tuple (Id _ _ _ (TupleConId _) _ _) = True
501 is_tuple (Id _ _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
502 is_tuple other = False
505 isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _)
506 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
507 Just (unspec, ty_maybes)
508 isSpecId_maybe other_id
511 isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId specid _) _ _)
513 isSpecPragmaId_maybe other_id
518 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a nested
519 @let(rec)@ (returns @False@), or whether it is {\em sure} to be
520 defined at top level (returns @True@). This is used to decide whether
521 the @Id@ is a candidate free variable. NB: you are only {\em sure}
522 about something if it returns @True@!
525 toplevelishId :: Id -> Bool
526 idHasNoFreeTyVars :: Id -> Bool
528 toplevelishId (Id _ _ _ details _ _)
531 chk (DataConId _ _ _ _ _ _ _) = True
532 chk (TupleConId _) = True
533 chk (RecordSelId _) = True
534 chk ImportedId = True
535 chk TopLevId = True -- NB: see notes
536 chk (SuperDictSelId _ _) = True
537 chk (MethodSelId _ _) = True
538 chk (DefaultMethodId _ _ _) = True
539 chk (DictFunId _ _ _) = True
540 chk (ConstMethodId _ _ _ _) = True
541 chk (SpecId unspec _ _) = toplevelishId unspec
542 -- depends what the unspecialised thing is
543 chk (WorkerId unwrkr) = toplevelishId unwrkr
544 chk (InstId _) = False -- these are local
545 chk (LocalId _) = False
546 chk (SysLocalId _) = False
547 chk (SpecPragmaId _ _) = False
549 idHasNoFreeTyVars (Id _ _ _ details _ info)
552 chk (DataConId _ _ _ _ _ _ _) = True
553 chk (TupleConId _) = True
554 chk (RecordSelId _) = True
555 chk ImportedId = True
557 chk (SuperDictSelId _ _) = True
558 chk (MethodSelId _ _) = True
559 chk (DefaultMethodId _ _ _) = True
560 chk (DictFunId _ _ _) = True
561 chk (ConstMethodId _ _ _ _) = True
562 chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
563 chk (SpecId _ _ no_free_tvs) = no_free_tvs
564 chk (InstId no_free_tvs) = no_free_tvs
565 chk (LocalId no_free_tvs) = no_free_tvs
566 chk (SysLocalId no_free_tvs) = no_free_tvs
567 chk (SpecPragmaId _ no_free_tvs) = no_free_tvs
571 isTopLevId (Id _ _ _ TopLevId _ _) = True
572 isTopLevId other = False
574 isImportedId (Id _ _ _ ImportedId _ _) = True
575 isImportedId other = False
577 isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
579 isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True
580 isSysLocalId other = False
582 isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True
583 isSpecPragmaId other = False
585 isMethodSelId (Id _ _ _ (MethodSelId _ _) _ _) = True
586 isMethodSelId _ = False
588 isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
589 isDefaultMethodId other = False
591 isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _)
592 = Just (cls, clsop, err)
593 isDefaultMethodId_maybe other = Nothing
595 isDictFunId (Id _ _ _ (DictFunId _ _ _) _ _) = True
596 isDictFunId other = False
598 isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True
599 isConstMethodId other = False
601 isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _) _ _)
602 = Just (cls, ty, clsop)
603 isConstMethodId_maybe other = Nothing
605 isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
606 isSuperDictSelId_maybe other_id = Nothing
608 isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
609 isWorkerId other = False
611 isWrapperId id = workerExists (getIdStrictness id)
616 pprIdInUnfolding :: IdSet -> Id -> Pretty
618 pprIdInUnfolding in_scopes v
623 if v `elementOfUniqSet` in_scopes then
624 pprUnique (idUnique v)
626 -- ubiquitous Ids with special syntax:
627 else if v == nilDataCon then
629 else if isTupleCon v then
630 ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
632 -- ones to think about:
635 (Id _ _ _ v_details _ _) = v
638 -- these ones must have been exported by their original module
639 ImportedId -> pp_full_name
641 -- these ones' exportedness checked later...
642 TopLevId -> pp_full_name
643 DataConId _ _ _ _ _ _ _ -> pp_full_name
645 RecordSelId lbl -> ppr sty lbl
647 -- class-ish things: class already recorded as "mentioned"
649 -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
651 -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
652 DefaultMethodId c o _
653 -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
655 -- instance-ish things: should we try to figure out
656 -- *exactly* which extra instances have to be exported? (ToDo)
658 -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
659 ConstMethodId c t o _
660 -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
662 -- specialisations and workers
663 SpecId unspec ty_maybes _
665 pp = pprIdInUnfolding in_scopes unspec
667 ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
668 ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
673 pp = pprIdInUnfolding in_scopes unwrkr
675 ppBeside (ppPStr SLIT("_WRKR_ ")) pp
677 -- anything else? we're nae interested
678 other_id -> panic "pprIdInUnfolding:mystery Id"
680 ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
684 (OrigName m_str n_str) = origName "Id:ppr_Unfolding" v
687 if isLexSym n_str && not (isLexSpecialSym n_str) then
688 ppBesides [ppLparen, ppPStr n_str, ppRparen]
692 if isPreludeDefined v then
695 ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
697 pp_class :: Class -> Pretty
698 pp_class_op :: ClassOp -> Pretty
699 pp_type :: Type -> Pretty
700 pp_ty_maybe :: Maybe Type -> Pretty
702 pp_class clas = ppr ppr_Unfolding clas
703 pp_class_op op = ppr ppr_Unfolding op
705 pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
707 pp_ty_maybe Nothing = ppPStr SLIT("_N_")
708 pp_ty_maybe (Just t) = pp_type t
712 @whatsMentionedInId@ ferrets out the types/classes/instances on which
713 this @Id@ depends. If this Id is to appear in an interface, then
714 those entities had Jolly Well be in scope. Someone else up the
715 call-tree decides that.
720 :: IdSet -- Ids known to be in scope
721 -> Id -- Id being processed
722 -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
724 whatsMentionedInId in_scopes v
729 = getMentionedTyConsAndClassesFromType v_ty
731 result0 id_bag = (id_bag, tycons, clss)
734 = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
735 tcs `unionBags` tycons,
739 if v `elementOfUniqSet` in_scopes then
740 result0 emptyBag -- v not added to "mentioned"
742 -- ones to think about:
745 (Id _ _ _ v_details _ _) = v
748 -- specialisations and workers
749 SpecId unspec ty_maybes _
751 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
753 result1 ids2 tcs2 cs2
757 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
759 result1 ids2 tcs2 cs2
761 anything_else -> result0 (unitBag v) -- v is added to "mentioned"
765 Tell them who my wrapper function is.
768 myWrapperMaybe :: Id -> Maybe Id
770 myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
771 myWrapperMaybe other_id = Nothing
776 unfoldingUnfriendlyId -- return True iff it is definitely a bad
777 :: Id -- idea to export an unfolding that
778 -> Bool -- mentions this Id. Reason: it cannot
779 -- possibly be seen in another module.
781 unfoldingUnfriendlyId id = True -- ToDo:panic "Id.unfoldingUnfriendlyId"
784 unfoldingUnfriendlyId id
785 | not (externallyVisibleId id) -- that settles that...
788 unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper) _ _)
789 = class_thing wrapper
791 -- "class thing": If we're going to use this worker Id in
792 -- an interface, we *have* to be able to untangle the wrapper's
793 -- strictness when reading it back in. At the moment, this
794 -- is not always possible: in precisely those cases where
795 -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
797 class_thing (Id _ _ _ (SuperDictSelId _ _) _ _) = True
798 class_thing (Id _ _ _ (MethodSelId _ _) _ _) = True
799 class_thing (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
800 class_thing other = False
802 unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _) _ _)
803 -- a SPEC of a DictFunId can end up w/ gratuitous
804 -- TyVar(Templates) in the i/face; only a problem
805 -- if -fshow-pragma-name-errs; but we can do without the pain.
806 -- A HACK in any case (WDP 94/05/02)
807 = naughty_DictFunId dfun
809 unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _) _ _)
810 = naughty_DictFunId dfun -- similar deal...
812 unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
814 naughty_DictFunId :: IdDetails -> Bool
815 -- True <=> has a TyVar(Template) in the "type" part of its "name"
817 naughty_DictFunId (DictFunId _ _ _) = panic "False" -- came from outside; must be OK
818 naughty_DictFunId (DictFunId _ ty _)
819 = not (isGroundTy ty)
823 @externallyVisibleId@: is it true that another module might be
824 able to ``see'' this Id?
826 We need the @toplevelishId@ check as well as @isExported@ for when we
827 compile instance declarations in the prelude. @DictFunIds@ are
828 ``exported'' if either their class or tycon is exported, but, in
829 compiling the prelude, the compiler may not recognise that as true.
832 externallyVisibleId :: Id -> Bool
834 externallyVisibleId id@(Id _ _ _ details _ _)
835 = if isLocallyDefined id then
836 toplevelishId id && (isExported id || isDataCon id)
837 -- NB: the use of "isExported" is most dodgy;
838 -- We may eventually move to a situation where
839 -- every Id is "externallyVisible", even if the
840 -- module system's namespace control renders it
844 -- if visible here, it must be visible elsewhere, too.
848 idWantsToBeINLINEd :: Id -> Bool
850 idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
851 idWantsToBeINLINEd _ = False
854 For @unlocaliseId@: See the brief commentary in
855 \tr{simplStg/SimplStg.lhs}.
859 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
861 unlocaliseId mod (Id u fn ty info TopLevId)
862 = Just (Id u (unlocaliseFullName fn) ty info TopLevId)
864 unlocaliseId mod (Id u sn ty info (LocalId no_ftvs))
865 = --false?: ASSERT(no_ftvs)
867 full_name = unlocaliseShortName mod u sn
869 Just (Id u full_name ty info TopLevId)
871 unlocaliseId mod (Id u sn ty info (SysLocalId no_ftvs))
872 = --false?: on PreludeGlaST: ASSERT(no_ftvs)
874 full_name = unlocaliseShortName mod u sn
876 Just (Id u full_name ty info TopLevId)
878 unlocaliseId mod (Id u n ty info (SpecId unspec ty_maybes no_ftvs))
879 = case unlocalise_parent mod u unspec of
881 Just xx -> Just (Id u n ty info (SpecId xx ty_maybes no_ftvs))
883 unlocaliseId mod (Id u n ty info (WorkerId unwrkr))
884 = case unlocalise_parent mod u unwrkr of
886 Just xx -> Just (Id u n ty info (WorkerId xx))
888 unlocaliseId mod (Id u name ty info (InstId no_ftvs))
889 = Just (Id u full_name ty info TopLevId)
890 -- type might be wrong, but it hardly matters
891 -- at this stage (just before printing C) ToDo
893 name = nameOf (origName "Id.unlocaliseId" name)
894 full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
896 unlocaliseId mod other_id = Nothing
899 -- we have to be Very Careful for workers/specs of
902 unlocalise_parent mod uniq (Id _ sn ty info (LocalId no_ftvs))
903 = --false?: ASSERT(no_ftvs)
905 full_name = unlocaliseShortName mod uniq sn
907 Just (Id uniq full_name ty info TopLevId)
909 unlocalise_parent mod uniq (Id _ sn ty info (SysLocalId no_ftvs))
910 = --false?: ASSERT(no_ftvs)
912 full_name = unlocaliseShortName mod uniq sn
914 Just (Id uniq full_name ty info TopLevId)
916 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
917 -- we're OK otherwise
921 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
922 `Top-levelish Ids'' cannot have any free type variables, so applying
923 the type-env cannot have any effect. (NB: checked in CoreLint?)
925 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
926 former ``should be'' the usual crunch point.
929 type TypeEnv = TyVarEnv Type
931 applyTypeEnvToId :: TypeEnv -> Id -> Id
933 applyTypeEnvToId type_env id@(Id _ _ ty _ _ _)
934 | idHasNoFreeTyVars id
937 = apply_to_Id ( \ ty ->
938 applyTypeEnvToTy type_env ty
943 apply_to_Id :: (Type -> Type) -> Id -> Id
945 apply_to_Id ty_fn (Id u n ty details prag info)
949 Id u n new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
951 apply_to_details (SpecId unspec ty_maybes no_ftvs)
953 new_unspec = apply_to_Id ty_fn unspec
954 new_maybes = map apply_to_maybe ty_maybes
956 SpecId new_unspec new_maybes (no_free_tvs ty)
957 -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
959 apply_to_maybe Nothing = Nothing
960 apply_to_maybe (Just ty) = Just (ty_fn ty)
962 apply_to_details (WorkerId unwrkr)
964 new_unwrkr = apply_to_Id ty_fn unwrkr
968 apply_to_details other = other
971 Sadly, I don't think the one using the magic typechecker substitution
972 can be done with @apply_to_Id@. Here we go....
974 Strictness is very important here. We can't leave behind thunks
975 with pointers to the substitution: it {\em must} be single-threaded.
979 applySubstToId :: Subst -> Id -> (Subst, Id)
981 applySubstToId subst id@(Id u n ty info details)
982 -- *cannot* have a "idHasNoFreeTyVars" get-out clause
983 -- because, in the typechecker, we are still
984 -- *concocting* the types.
985 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
986 case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
987 case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
988 (s4, Id u n new_ty new_info new_details) }}}
990 apply_to_details subst _ (InstId inst no_ftvs)
991 = case (applySubstToInst subst inst) of { (s2, new_inst) ->
992 (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
994 apply_to_details subst new_ty (SpecId unspec ty_maybes _)
995 = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
996 case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
997 (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
998 -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
1000 apply_to_maybe subst Nothing = (subst, Nothing)
1001 apply_to_maybe subst (Just ty)
1002 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
1005 apply_to_details subst _ (WorkerId unwrkr)
1006 = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
1007 (s2, WorkerId new_unwrkr) }
1009 apply_to_details subst _ other = (subst, other)
1013 %************************************************************************
1015 \subsection[Id-type-funs]{Type-related @Id@ functions}
1017 %************************************************************************
1020 idType :: GenId ty -> ty
1022 idType (Id _ _ ty _ _ _) = ty
1027 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1029 getMentionedTyConsAndClassesFromId id
1030 = getMentionedTyConsAndClassesFromType (idType id)
1035 idPrimRep i = typePrimRep (idType i)
1040 getInstIdModule (Id _ _ _ (DictFunId _ _ mod)) = mod
1041 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ mod)) = mod
1042 getInstIdModule other = panic "Id:getInstIdModule"
1046 %************************************************************************
1048 \subsection[Id-overloading]{Functions related to overloading}
1050 %************************************************************************
1053 mkSuperDictSelId u c sc ty info
1054 = mk_classy_id (SuperDictSelId c sc) SLIT("sdsel") (Left (origName "mkSuperDictSelId" sc)) u c ty info
1056 mkMethodSelId u rec_c op ty info
1057 = mk_classy_id (MethodSelId rec_c op) SLIT("meth") (Right (classOpString op)) u rec_c ty info
1059 mkDefaultMethodId u rec_c op gen ty info
1060 = mk_classy_id (DefaultMethodId rec_c op gen) SLIT("defm") (Right (classOpString op)) u rec_c ty info
1062 mk_classy_id details str op_str u rec_c ty info
1063 = Id u n ty details NoPragmaInfo info
1065 cname = getName rec_c -- we get other info out of here
1066 cname_orig = origName "mk_classy_id" cname
1067 cmod = moduleOf cname_orig
1069 n = mkCompoundName u cmod str [Left cname_orig, op_str] cname
1071 mkDictFunId u c ity full_ty from_here locn mod info
1072 = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info
1074 n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : renum_type_string full_ty ity) from_here locn
1076 mkConstMethodId u c op ity full_ty from_here locn mod info
1077 = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info
1079 n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : renum_type_string full_ty ity) from_here locn
1081 renum_type_string full_ty ity
1083 nmbrType full_ty `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering...
1084 nmbrType ity `thenNmbr` \ rn_ity ->
1085 returnNmbr (getTypeString rn_ity)
1088 mkWorkerId u unwrkr ty info
1089 = Id u n ty (WorkerId unwrkr) NoPragmaInfo info
1091 unwrkr_name = getName unwrkr
1092 unwrkr_orig = trace "mkWorkerId:origName:" $ origName "mkWorkerId" unwrkr_name
1093 umod = moduleOf unwrkr_orig
1095 n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name
1097 mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
1100 getConstMethodId clas op ty
1101 = -- constant-method info is hidden in the IdInfo of
1102 -- the class-op id (as mentioned up above).
1104 sel_id = getMethodSelId clas op
1106 case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1108 Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
1109 ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1110 ppr PprDebug sel_id],
1111 ppStr "(This can arise if an interface pragma refers to an instance",
1112 ppStr "but there is no imported interface which *defines* that instance.",
1113 ppStr "The info above, however ugly, should indicate what else you need to import."
1118 %************************************************************************
1120 \subsection[local-funs]{@LocalId@-related functions}
1122 %************************************************************************
1125 mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
1128 updateIdType :: Id -> Type -> Id
1129 updateIdType (Id u n _ info details) ty = Id u n ty info details
1134 type MyTy a b = GenType (GenTyVar a) b
1135 type MyId a b = GenId (MyTy a b)
1137 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1139 -- SysLocal: for an Id being created by the compiler out of thin air...
1140 -- UserLocal: an Id with a name the user might recognize...
1141 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1143 mkSysLocal str uniq ty loc
1144 = Id uniq (mkLocalName uniq str True{-emph uniq-} loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
1146 mkUserLocal str uniq ty loc
1147 = Id uniq (mkLocalName uniq str False{-emph name-} loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
1149 -- mkUserId builds a local or top-level Id, depending on the name given
1150 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1151 mkUserId name ty pragma_info
1153 = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo
1155 = Id (nameUnique name) name ty
1156 (if isLocallyDefinedName name then TopLevId else ImportedId)
1157 pragma_info noIdInfo
1164 -- for a SpecPragmaId being created by the compiler out of thin air...
1165 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1166 mkSpecPragmaId str uniq ty specid loc
1167 = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty))
1170 mkSpecId u unspec ty_maybes ty info
1171 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1172 Id u n ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1174 -- Specialised version of constructor: only used in STG and code generation
1175 -- Note: The specialsied Id has the same unique as the unspeced Id
1177 mkSameSpecCon ty_maybes unspec@(Id u n ty info details)
1178 = ASSERT(isDataCon unspec)
1179 ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1180 Id u n new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1182 new_ty = specialiseTy ty ty_maybes 0
1184 localiseId :: Id -> Id
1185 localiseId id@(Id u n ty info details)
1186 = Id u (mkShortName name loc) ty info (LocalId (no_free_tvs ty))
1188 name = getOccName id
1192 mkIdWithNewUniq :: Id -> Unique -> Id
1194 mkIdWithNewUniq (Id _ n ty details prag info) u
1195 = Id u (changeUnique n u) ty details prag info
1198 Make some local @Ids@ for a template @CoreExpr@. These have bogus
1199 @Uniques@, but that's OK because the templates are supposed to be
1200 instantiated before use.
1202 mkTemplateLocals :: [Type] -> [Id]
1203 mkTemplateLocals tys
1204 = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1205 (getBuiltinUniques (length tys))
1210 getIdInfo :: GenId ty -> IdInfo
1211 getPragmaInfo :: GenId ty -> PragmaInfo
1213 getIdInfo (Id _ _ _ _ _ info) = info
1214 getPragmaInfo (Id _ _ _ _ info _) = info
1216 replaceIdInfo :: Id -> IdInfo -> Id
1218 replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
1221 selectIdInfoForSpecId :: Id -> IdInfo
1222 selectIdInfoForSpecId unspec
1223 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1224 noIdInfo `addInfo_UF` getIdUnfolding unspec
1228 %************************************************************************
1230 \subsection[Id-arities]{Arity-related functions}
1232 %************************************************************************
1234 For locally-defined Ids, the code generator maintains its own notion
1235 of their arities; so it should not be asking... (but other things
1236 besides the code-generator need arity info!)
1239 getIdArity :: Id -> ArityInfo
1240 getIdArity id@(Id _ _ _ _ _ id_info)
1241 = --ASSERT( not (isDataCon id))
1244 dataConArity, dataConNumFields :: DataCon -> Int
1246 dataConArity id@(Id _ _ _ _ _ id_info)
1247 = ASSERT(isDataCon id)
1248 case (arityMaybe (getInfo id_info)) of
1250 Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1253 = ASSERT(isDataCon id)
1254 case (dataConSig id) of { (_, _, arg_tys, _) ->
1257 isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
1259 addIdArity :: Id -> Int -> Id
1260 addIdArity (Id u n ty details pinfo info) arity
1261 = Id u n ty details pinfo (info `addInfo` (mkArityInfo arity))
1264 %************************************************************************
1266 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1268 %************************************************************************
1272 -> [StrictnessMark] -> [FieldLabel]
1273 -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1276 -- can get the tag and all the pieces of the type from the Type
1278 mkDataCon n stricts fields tvs ctxt args_tys tycon
1279 = ASSERT(length stricts == length args_tys)
1282 -- NB: data_con self-recursion; should be OK as tags are not
1283 -- looked at until late in the game.
1288 (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
1289 IWantToBeINLINEd -- Always inline constructors if possible
1292 data_con_tag = position_within fIRST_TAG data_con_family
1294 data_con_family = tyConDataCons tycon
1296 position_within :: Int -> [Id] -> Int
1298 position_within acc (c:cs)
1299 = if c == data_con then acc else position_within (acc+1) cs
1301 position_within acc []
1302 = panic "mkDataCon: con not found in family"
1306 = mkSigmaTy tvs ctxt
1307 (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1309 datacon_info = noIdInfo `addInfo_UF` unfolding
1310 `addInfo` mkArityInfo arity
1311 --ToDo: `addInfo` specenv
1313 arity = length ctxt + length args_tys
1320 -- else -- do some business...
1322 (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1323 tyvar_tys = mkTyVarTys tyvars
1325 case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
1327 mkUnfolding EssentialUnfolding -- for data constructors
1328 (mkLam tyvars (dict_vars ++ vars) plain_Con)
1331 mk_uf_bits tvs ctxt arg_tys tycon
1333 (inst_env, tyvars, tyvar_tys)
1334 = instantiateTyVarTemplates tvs
1337 -- the "context" and "arg_tys" have TyVarTemplates in them, so
1338 -- we instantiate those types to have the right TyVars in them
1340 case (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1341 of { inst_dict_tys ->
1342 case (map (instantiateTauTy inst_env) arg_tys) of { inst_arg_tys ->
1344 -- We can only have **ONE** call to mkTemplateLocals here;
1345 -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1346 -- (Mega-Sigh) [ToDo]
1347 case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars ->
1349 case (splitAt (length ctxt) all_vars) of { (dict_vars, vars) ->
1351 (tyvars, dict_vars, vars)
1354 -- these are really dubious Types, but they are only to make the
1355 -- binders for the lambdas for tossed-away dicts.
1356 ctxt_ty (clas, ty) = mkDictTy clas ty
1361 mkTupleCon :: Arity -> Id
1364 = Id unique n ty (TupleConId arity) NoPragmaInfo tuplecon_info
1366 n = mkTupleDataConName arity
1368 ty = mkSigmaTy tyvars []
1369 (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1370 tycon = mkTupleTyCon arity
1371 tyvars = take arity alphaTyVars
1372 tyvar_tys = mkTyVarTys tyvars
1375 = noIdInfo `addInfo_UF` unfolding
1376 `addInfo` mkArityInfo arity
1377 --LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1384 -- else -- do some business...
1386 (tyvars, dict_vars, vars) = mk_uf_bits arity
1387 tyvar_tys = mkTyVarTys tyvars
1389 case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
1391 EssentialUnfolding -- data constructors
1392 (mkLam tyvars (dict_vars ++ vars) plain_Con) }
1395 = case (mkTemplateLocals tyvar_tys) of { vars ->
1396 (tyvars, [], vars) }
1398 tyvar_tmpls = take arity alphaTyVars
1399 (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
1403 fIRST_TAG = 1 -- Tags allocated from here for real constructors
1407 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1408 dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _) _ _) = tag
1409 dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG
1410 dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
1412 dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
1413 dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
1414 dataConTyCon (Id _ _ _ (TupleConId a) _ _) = mkTupleTyCon a
1416 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1417 -- will panic if not a DataCon
1419 dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1420 = (tyvars, theta_ty, arg_tys, tycon)
1422 dataConSig (Id _ _ _ (TupleConId arity) _ _)
1423 = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1425 tyvars = take arity alphaTyVars
1426 tyvar_tys = mkTyVarTys tyvars
1428 dataConFieldLabels :: DataCon -> [FieldLabel]
1429 dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields
1430 dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = []
1432 dataConStrictMarks :: DataCon -> [StrictnessMark]
1433 dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts
1434 dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _)
1435 = nOfThem arity NotMarkedStrict
1437 dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
1438 dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
1440 dataConArgTys :: DataCon
1441 -> [Type] -- Instantiated at these types
1442 -> [Type] -- Needs arguments of these types
1443 dataConArgTys con_id inst_tys
1444 = map (instantiateTy tenv) arg_tys
1446 (tyvars, _, arg_tys, _) = dataConSig con_id
1447 tenv = zipEqual "dataConArgTys" tyvars inst_tys
1451 mkRecordSelId field_label selector_ty
1452 = Id (nameUnique name)
1455 (RecordSelId field_label)
1459 name = fieldLabelName field_label
1461 recordSelectorFieldLabel :: Id -> FieldLabel
1462 recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl
1466 Data type declarations are of the form:
1468 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1470 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1471 @C1 x y z@, we want a function binding:
1473 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1475 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1476 2nd-order polymorphic lambda calculus with explicit types.
1478 %************************************************************************
1480 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1482 %************************************************************************
1484 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1485 and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
1486 @TyVars@ don't really have to be new, because we are only producing a
1489 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1492 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1493 EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the
1494 example above: a, b, and x, y, z], which is enough (in the important
1495 \tr{DsExpr} case). (The middle set of @Ids@ is binders for any
1496 dictionaries, in the even of an overloaded data-constructor---none at
1500 getIdUnfolding :: Id -> UnfoldingDetails
1502 getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
1505 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1506 addIdUnfolding id@(Id u n ty info details) unfold_details
1508 case (isLocallyDefined id, unfold_details) of
1509 (_, NoUnfoldingDetails) -> True
1510 (True, IWantToBeINLINEd _) -> True
1511 (False, IWantToBeINLINEd _) -> False -- v bad
1515 Id u n ty (info `addInfo_UF` unfold_details) details
1519 In generating selector functions (take a dictionary, give back one
1520 component...), we need to what out for the nothing-to-select cases (in
1521 which case the ``selector'' is just an identity function):
1523 class Eq a => Foo a { } # the superdict selector for "Eq"
1525 class Foo a { op :: Complex b => c -> b -> a }
1526 # the method selector for "op";
1527 # note local polymorphism...
1530 %************************************************************************
1532 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1534 %************************************************************************
1537 getIdDemandInfo :: Id -> DemandInfo
1538 getIdDemandInfo (Id _ _ _ _ _ info) = getInfo info
1540 addIdDemandInfo :: Id -> DemandInfo -> Id
1541 addIdDemandInfo (Id u n ty details prags info) demand_info
1542 = Id u n ty details prags (info `addInfo` demand_info)
1546 getIdUpdateInfo :: Id -> UpdateInfo
1547 getIdUpdateInfo (Id _ _ _ _ _ info) = getInfo info
1549 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1550 addIdUpdateInfo (Id u n ty details prags info) upd_info
1551 = Id u n ty details prags (info `addInfo` upd_info)
1556 getIdArgUsageInfo :: Id -> ArgUsageInfo
1557 getIdArgUsageInfo (Id u n ty info details) = getInfo info
1559 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1560 addIdArgUsageInfo (Id u n ty info details) au_info
1561 = Id u n ty (info `addInfo` au_info) details
1567 getIdFBTypeInfo :: Id -> FBTypeInfo
1568 getIdFBTypeInfo (Id u n ty info details) = getInfo info
1570 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1571 addIdFBTypeInfo (Id u n ty info details) upd_info
1572 = Id u n ty (info `addInfo` upd_info) details
1578 getIdSpecialisation :: Id -> SpecEnv
1579 getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
1581 addIdSpecialisation :: Id -> SpecEnv -> Id
1582 addIdSpecialisation (Id u n ty details prags info) spec_info
1583 = Id u n ty details prags (info `addInfo` spec_info)
1587 Strictness: we snaffle the info out of the IdInfo.
1590 getIdStrictness :: Id -> StrictnessInfo
1592 getIdStrictness (Id _ _ _ _ _ info) = getInfo info
1594 addIdStrictness :: Id -> StrictnessInfo -> Id
1596 addIdStrictness (Id u n ty details prags info) strict_info
1597 = Id u n ty details prags (info `addInfo` strict_info)
1600 %************************************************************************
1602 \subsection[Id-comparison]{Comparison functions for @Id@s}
1604 %************************************************************************
1606 Comparison: equality and ordering---this stuff gets {\em hammered}.
1609 cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = cmp u1 u2
1610 -- short and very sweet
1614 instance Ord3 (GenId ty) where
1617 instance Eq (GenId ty) where
1618 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
1619 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
1621 instance Ord (GenId ty) where
1622 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
1623 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
1624 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
1625 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
1626 _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1629 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1630 account when comparing two data constructors. We need to do this
1631 because a specialised data constructor has the same Unique as its
1632 unspecialised counterpart.
1635 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1637 cmpId_withSpecDataCon id1 id2
1638 | eq_ids && isDataCon id1 && isDataCon id2
1639 = cmpEqDataCon id1 id2
1644 cmp_ids = cmpId id1 id2
1645 eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
1647 cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _)
1648 = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1650 cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_
1651 cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_
1652 cmpEqDataCon _ _ = EQ_
1655 %************************************************************************
1657 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1659 %************************************************************************
1662 instance Outputable ty => Outputable (GenId ty) where
1663 ppr sty id = pprId sty id
1665 -- and a SPECIALIZEd one:
1666 instance Outputable {-Id, i.e.:-}(GenId Type) where
1667 ppr sty id = pprId sty id
1669 showId :: PprStyle -> Id -> String
1670 showId sty id = ppShow 80 (pprId sty id)
1673 Default printing code (not used for interfaces):
1675 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1677 pprId sty (Id u n _ _ _ _) = ppr sty n
1678 -- WDP 96/05/06: We can re-elaborate this as we go along...
1682 idUnique (Id u _ _ _ _ _) = u
1684 instance Uniquable (GenId ty) where
1687 instance NamedThing (GenId ty) where
1688 getName this_id@(Id u n _ details _ _) = n
1691 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1692 the @Uniques@ out of local @Ids@ given to it.
1694 %************************************************************************
1696 \subsection{@IdEnv@s and @IdSet@s}
1698 %************************************************************************
1701 type IdEnv elt = UniqFM elt
1703 nullIdEnv :: IdEnv a
1705 mkIdEnv :: [(GenId ty, a)] -> IdEnv a
1706 unitIdEnv :: GenId ty -> a -> IdEnv a
1707 addOneToIdEnv :: IdEnv a -> GenId ty -> a -> IdEnv a
1708 growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
1709 growIdEnvList :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1711 delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
1712 delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
1713 combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1714 mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
1715 modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
1716 rngIdEnv :: IdEnv a -> [a]
1718 isNullIdEnv :: IdEnv a -> Bool
1719 lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a
1720 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1724 addOneToIdEnv = addToUFM
1725 combineIdEnvs = plusUFM_C
1726 delManyFromIdEnv = delListFromUFM
1727 delOneFromIdEnv = delFromUFM
1729 lookupIdEnv = lookupUFM
1732 nullIdEnv = emptyUFM
1736 growIdEnvList env pairs = plusUFM env (listToUFM pairs)
1737 isNullIdEnv env = sizeUFM env == 0
1738 lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
1740 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1741 -- modify function, and put it back.
1743 modifyIdEnv env mangle_fn key
1744 = case (lookupIdEnv env key) of
1746 Just xx -> addOneToIdEnv env key (mangle_fn xx)
1750 type GenIdSet ty = UniqSet (GenId ty)
1751 type IdSet = UniqSet (GenId Type)
1753 emptyIdSet :: GenIdSet ty
1754 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1755 unionIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1756 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1757 idSetToList :: GenIdSet ty -> [GenId ty]
1758 unitIdSet :: GenId ty -> GenIdSet ty
1759 addOneToIdSet :: GenIdSet ty -> GenId ty -> GenIdSet ty
1760 elementOfIdSet :: GenId ty -> GenIdSet ty -> Bool
1761 minusIdSet :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1762 isEmptyIdSet :: GenIdSet ty -> Bool
1763 mkIdSet :: [GenId ty] -> GenIdSet ty
1765 emptyIdSet = emptyUniqSet
1766 unitIdSet = unitUniqSet
1767 addOneToIdSet = addOneToUniqSet
1768 intersectIdSets = intersectUniqSets
1769 unionIdSets = unionUniqSets
1770 unionManyIdSets = unionManyUniqSets
1771 idSetToList = uniqSetToList
1772 elementOfIdSet = elementOfUniqSet
1773 minusIdSet = minusUniqSet
1774 isEmptyIdSet = isEmptyUniqSet
1779 addId, nmbrId, nmbrDataCon :: Id -> NmbrM Id
1781 addId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1782 = case (lookupUFM_Directly idenv u) of
1783 Just xx -> trace "addId: already in map!" $
1786 if toplevelishId id then
1787 trace "addId: can't add toplevelish!" $
1789 else -- alloc a new unique for this guy
1790 -- and add an entry in the idenv
1791 -- NB: *** KNOT-TYING ***
1793 nenv_plus_id = NmbrEnv (incrUnique ui) ut uu
1794 (addToUFM_Directly idenv u new_id)
1797 (nenv2, new_ty) = nmbrType ty nenv_plus_id
1798 (nenv3, new_det) = nmbr_details det nenv2
1800 new_id = Id ui n new_ty new_det prag info
1804 nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1805 = case (lookupUFM_Directly idenv u) of
1806 Just xx -> (nenv, xx)
1808 if not (toplevelishId id) then
1809 trace "nmbrId: lookup failed" $
1813 (nenv2, new_ty) = nmbrType ty nenv
1814 (nenv3, new_det) = nmbr_details det nenv2
1816 new_id = Id u n new_ty new_det prag info
1820 -- used when renumbering TyCons to produce data decls...
1821 nmbrDataCon id@(Id _ _ _ (TupleConId _) _ _) nenv
1822 = (nenv, id) -- nothing to do for tuples
1824 nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta arg_tys tc) prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1825 = case (lookupUFM_Directly idenv u) of
1826 Just xx -> trace "nmbrDataCon: in env???\n" (nenv, xx)
1829 (nenv2, new_fields) = (mapNmbr nmbrField fields) nenv
1830 (nenv3, new_arg_tys) = (mapNmbr nmbrType arg_tys) nenv2
1832 new_det = DataConId tag marks new_fields (bottom "tvs") (bottom "theta") new_arg_tys tc
1833 new_id = Id u n (bottom "ty") new_det prag info
1837 bottom msg = panic ("nmbrDataCon"++msg)
1840 nmbr_details :: IdDetails -> NmbrM IdDetails
1842 nmbr_details (DataConId tag marks fields tvs theta arg_tys tc)
1843 = mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs ->
1844 mapNmbr nmbrField fields `thenNmbr` \ new_fields ->
1845 mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
1846 mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys ->
1847 returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_arg_tys tc)
1850 = --nmbrClass c `thenNmbr` \ new_c ->
1851 nmbrType t `thenNmbr` \ new_t ->
1852 returnNmbr (c, new_t)
1854 -- ToDo:add more cases as needed
1855 nmbr_details other_details = returnNmbr other_details
1858 nmbrField (FieldLabel n ty tag)
1859 = nmbrType ty `thenNmbr` \ new_ty ->
1860 returnNmbr (FieldLabel n new_ty tag)