2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[Id]{@Ids@: Value and constructor identifiers}
7 #include "HsVersions.h"
11 IdInfo, -- re-exporting
12 ConTag(..), DictVar(..), DictFun(..), DataCon(..),
15 mkSysLocal, mkUserLocal,
17 mkSpecId, mkSameSpecCon,
18 selectIdInfoForSpecId,
20 mkImported, mkPreludeId,
21 mkDataCon, mkTupleCon,
23 mkClassOpId, mkSuperDictSelId, mkDefaultMethodId,
24 mkConstMethodId, mkInstId,
28 #endif {- Data Parallel Haskell -}
37 getInstNamePieces, getIdInfo, replaceIdInfo,
38 getIdKind, getInstIdModule,
39 getMentionedTyConsAndClassesFromId,
41 getDataConSig, getInstantiatedDataConSig,
42 getDataConTyCon, -- UNUSED: getDataConFamily,
43 #ifdef USE_SEMANTIQUE_STRANAL
48 isDataCon, isTupleCon, isNullaryDataCon,
49 isSpecId_maybe, isSpecPragmaId_maybe,
50 toplevelishId, externallyVisibleId,
51 isTopLevId, isWorkerId, isWrapperId,
52 isImportedId, isSysLocalId,
54 isClassOpId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
55 isDictFunId, isInstId_maybe, isConstMethodId_maybe,
59 #endif {- Data Parallel Haskell -}
61 cmpId_withSpecDataCon,
64 unfoldingUnfriendlyId, -- ToDo: rm, eventually
66 -- dataConMentionsNonPreludeTyCon,
69 applySubstToId, applyTypeEnvToId,
70 -- not exported: apply_to_Id, -- please don't use this, generally
72 -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
73 getIdArity, getDataConArity, addIdArity,
74 getIdDemandInfo, addIdDemandInfo,
75 getIdSpecialisation, addIdSpecialisation,
76 getIdStrictness, addIdStrictness,
77 getIdUnfolding, addIdUnfolding, -- UNUSED? clearIdUnfolding,
78 getIdUpdateInfo, addIdUpdateInfo,
79 getIdArgUsageInfo, addIdArgUsageInfo,
80 getIdFBTypeInfo, addIdFBTypeInfo,
81 -- don't export the types, lest OptIdInfo be dragged in!
89 -- and to make the interface self-sufficient...
90 Class, ClassOp, GlobalSwitch, Inst, Maybe, Name,
91 FullName, PprStyle, PrettyRep,
92 PrimKind, SrcLoc, Pretty(..), Subst, UnfoldingDetails,
93 TyCon, TyVar, TyVarTemplate, TauType(..), UniType, Unique,
94 UniqueSupply, Arity(..), ThetaType(..),
95 TypeEnv(..), UniqFM, InstTemplate, Bag,
96 SpecEnv, nullSpecEnv, SpecInfo,
98 -- and to make sure pragmas work...
99 IdDetails -- from this module, abstract
100 IF_ATTACK_PRAGMAS(COMMA getMentionedTyConsAndClassesFromUniType)
101 IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
102 IF_ATTACK_PRAGMAS(COMMA getInfo_UF)
104 #ifndef __GLASGOW_HASKELL__
109 IMPORT_Trace -- ToDo: rm (debugging only)
111 import AbsPrel ( PrimOp, PrimKind, mkFunTy, nilDataCon, pRELUDE_BUILTIN
112 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
113 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
115 , mkPodNTy, mkPodizedPodNTy
116 #endif {- Data Parallel Haskell -}
121 import CLabelInfo ( identToC, cSEP )
122 import CmdLineOpts ( GlobalSwitch(..) )
123 import IdEnv -- ( nullIdEnv, IdEnv )
124 import IdInfo -- piles of it
125 import Inst -- lots of things
126 import Maybes ( maybeToBool, Maybe(..) )
127 import Name ( Name(..) )
130 import Pretty -- for pretty-printing
132 import Subst ( applySubstToTy ) -- PRETTY GRIMY TO LOOK IN HERE
134 import PrelFuns ( pcGenerateTupleSpecs ) -- PRETTY GRIMY TO LOOK IN HERE
141 import PodizeCore ( podizeTemplateExpr )
142 import PodInfoTree ( infoTypeNumToMask )
143 #endif {- Data Parallel Haskell -}
146 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
149 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
150 @UniType@, and an @IdInfo@ (non-essential info about it, e.g.,
151 strictness). The essential info about different kinds of @Ids@ is
154 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
157 data Id = Id Unique -- key for fast comparison
158 UniType -- Id's type; used all the time;
159 IdInfo -- non-essential info about this Id;
160 IdDetails -- stuff about individual kinds of Ids.
164 ---------------- Local values
166 = LocalId ShortName -- mentioned by the user
167 Bool -- True <=> no free type vars
169 | SysLocalId ShortName -- made up by the compiler
170 Bool -- as for LocalId
172 | SpecPragmaId ShortName -- introduced by the compiler
173 (Maybe SpecInfo)-- for explicit specid in pragma
174 Bool -- as for LocalId
176 ---------------- Global values
178 | ImportedId FullName -- Id imported from an interface
180 | PreludeId FullName -- things < Prelude that compiler "knows" about
182 | TopLevId FullName -- Top-level in the orig source pgm
183 -- (not moved there by transformations).
185 -- a TopLevId's type may contain free type variables, if
186 -- the monomorphism restriction applies.
188 ---------------- Data constructors
192 -- cached pieces of the type:
193 [TyVarTemplate] [(Class,UniType)] [UniType] TyCon
195 -- forall tyvars . theta_ty =>
196 -- unitype_1 -> ... -> unitype_n -> tycon tyvars
198 -- "type ThetaType = [(Class, UniType)]"
200 -- The [TyVarTemplate] is in the same order as the args of the
201 -- TyCon for the constructor
203 | TupleConId Int -- Its arity
206 | ProcessorCon Int -- Its arity
207 #endif {- Data Parallel Haskell -}
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 | ClassOpId 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 ClassOpId 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 ClassOpId
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 DictFunIds are generated from instance decls.
238 instance Foo a => Foo [a] where
241 generates the dict fun id decl
243 dfun.Foo.[*] = \d -> ...
245 The dfun id is uniquely named by the (class, type) pair. Notice, it
246 isn't a (class,tycon) pair any more, because we may get manually or
247 automatically generated specialisations of the instance decl:
249 instance Foo [Int] where
256 The type variables in the name are irrelevant; we print them as stars.
259 | DictFunId Class -- A DictFun is uniquely identified
260 UniType -- by its class and type; this type has free type vars,
261 -- whose identity is irrelevant. Eg Class = Eq
263 -- The "a" is irrelevant. As it is too painful to
264 -- actually do comparisons that way, we kindly supply
265 -- a Unique for that purpose.
266 Bool -- True <=> from an instance decl in this mod
267 FAST_STRING -- module where instance came from
270 Constant method ids are generated from instance decls where
271 there is no context; that is, no dictionaries are needed to
272 construct the method. Example
274 instance Foo Int where
277 Then we get a constant method
282 It is possible, albeit unusual, to have a constant method
283 for an instance decl which has type vars:
285 instance Foo [a] where
289 We get the constant method
293 So a constant method is identified by a class/op/type triple.
294 The type variables in the type are irrelevant.
297 | ConstMethodId -- A method which depends only on the type of the
298 -- instance, and not on any further dictionaries etc.
299 Class -- Uniquely identified by:
300 UniType -- (class, type, classop) triple
302 Bool -- True <=> from an instance decl in this mod
303 FAST_STRING -- module where instance came from
305 | InstId Inst -- An instance of a dictionary, class operation,
306 -- or overloaded value
308 | SpecId -- A specialisation of another Id
309 Id -- Id of which this is a specialisation
310 [Maybe UniType] -- Types at which it is specialised;
311 -- A "Nothing" says this type ain't relevant.
312 Bool -- True <=> no free type vars; it's not enough
313 -- to know about the unspec version, because
314 -- we may specialise to a type w/ free tyvars
315 -- (i.e., in one of the "Maybe UniType" dudes).
317 | WorkerId -- A "worker" for some other Id
318 Id -- Id for which this is a worker
321 | PodId Int -- The dimension of the PODs context
322 Int -- Which specialisation of InfoType is
323 -- bind. ToDo(hilly): Int is a little messy
324 -- and has a restricted range---change.
325 Id -- One of the aboves Ids.
326 #endif {- Data Parallel Haskell -}
334 For Ids whose names must be known/deducible in other modules, we have
335 to conjure up their worker's names (and their worker's worker's
336 names... etc) in a known systematic way.
338 %************************************************************************
340 \subsection[Id-documentation]{Documentation}
342 %************************************************************************
346 The @Id@ datatype describes {\em values}. The basic things we want to
347 know: (1)~a value's {\em type} (@getIdUniType@ is a very common
348 operation in the compiler); and (2)~what ``flavour'' of value it might
349 be---for example, it can be terribly useful to know that a value is a
353 %----------------------------------------------------------------------
354 \item[@DataConId@:] For the data constructors declared by a @data@
355 declaration. Their type is kept in {\em two} forms---as a regular
356 @UniType@ (in the usual place), and also in its constituent pieces (in
357 the ``details''). We are frequently interested in those pieces.
359 %----------------------------------------------------------------------
360 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
361 the infinite family of tuples.
363 %----------------------------------------------------------------------
364 \item[@ImportedId@:] These are values defined outside this module.
365 {\em Everything} we want to know about them must be stored here (or in
368 %----------------------------------------------------------------------
369 \item[@PreludeId@:] ToDo
371 %----------------------------------------------------------------------
372 \item[@TopLevId@:] These are values defined at the top-level in this
373 module; i.e., those which {\em might} be exported (hence, a
374 @FullName@). It does {\em not} include those which are moved to the
375 top-level through program transformations.
377 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
378 Theoretically, they could be floated inwards, but there's no known
379 advantage in doing so. This way, we can keep them with the same
380 @Unique@ throughout (no cloning), and, in general, we don't have to be
381 so paranoid about them.
383 In particular, we had the following problem generating an interface:
384 We have to ``stitch together'' info (1)~from the typechecker-produced
385 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
386 what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change}
387 between (1) and (2), you're sunk!
389 %----------------------------------------------------------------------
390 \item[@ClassOpId@:] A selector from a dictionary; it may select either
391 a method or a dictionary for one of the class's superclasses.
393 %----------------------------------------------------------------------
396 @mkDictFunId [a,b..] theta C T@ is the function derived from the
399 instance theta => C (T a b ..) where
402 It builds function @Id@ which maps dictionaries for theta,
403 to a dictionary for C (T a b ..).
405 *Note* that with the ``Mark Jones optimisation'', the theta may
406 include dictionaries for the immediate superclasses of C at the type
409 %----------------------------------------------------------------------
412 %----------------------------------------------------------------------
415 %----------------------------------------------------------------------
418 %----------------------------------------------------------------------
419 \item[@LocalId@:] A purely-local value, e.g., a function argument,
420 something defined in a @where@ clauses, ... --- but which appears in
421 the original program text.
423 %----------------------------------------------------------------------
424 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
425 the original program text; these are introduced by the compiler in
428 %----------------------------------------------------------------------
429 \item[@SpecPragmaId@:] Introduced by the compiler to record
430 Specialisation pragmas. It is dead code which MUST NOT be removed
431 before specialisation.
436 %----------------------------------------------------------------------
439 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
440 @ClassOpIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
444 They have no free type variables, so if you are making a
445 type-variable substitution you don't need to look inside them.
447 They are constants, so they are not free variables. (When the STG
448 machine makes a closure, it puts all the free variables in the
449 closure; the above are not required.)
451 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
452 properties, but they may not.
456 %************************************************************************
458 \subsection[Id-general-funs]{General @Id@-related functions}
460 %************************************************************************
463 isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _)) = True
464 isDataCon (Id _ _ _ (TupleConId _)) = True
465 isDataCon (Id _ _ _ (SpecId unspec _ _)) = isDataCon unspec
467 isDataCon (ProcessorCon _ _) = True
468 isDataCon (PodId _ _ id ) = isDataCon id
469 #endif {- Data Parallel Haskell -}
470 isDataCon other = False
472 isTupleCon (Id _ _ _ (TupleConId _)) = True
473 isTupleCon (Id _ _ _ (SpecId unspec _ _)) = isTupleCon unspec
475 isTupleCon (PodId _ _ id) = isTupleCon id
476 #endif {- Data Parallel Haskell -}
477 isTupleCon other = False
479 isNullaryDataCon data_con
481 && (case arityMaybe (getIdArity data_con) of
483 _ -> panic "isNullaryDataCon")
485 isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _))
486 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
487 Just (unspec, ty_maybes)
488 isSpecId_maybe other_id
491 isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId _ specinfo _))
493 isSpecPragmaId_maybe other_id
497 isProcessorCon (ProcessorCon _ _) = True
498 isProcessorCon (PodId _ _ id) = isProcessorCon id
499 isProcessorCon other = False
500 #endif {- Data Parallel Haskell -}
503 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a
504 nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be
505 defined at top level (returns @True@). This is used to decide whether
506 the @Id@ is a candidate free variable. NB: you are only {\em sure}
507 about something if it returns @True@!
510 toplevelishId :: Id -> Bool
511 idHasNoFreeTyVars :: Id -> Bool
513 toplevelishId (Id _ _ _ details)
516 chk (DataConId _ _ _ _ _ _) = True
517 chk (TupleConId _) = True
518 chk (ImportedId _) = True
519 chk (PreludeId _) = True
520 chk (TopLevId _) = True -- NB: see notes
521 chk (SuperDictSelId _ _) = True
522 chk (ClassOpId _ _) = True
523 chk (DefaultMethodId _ _ _) = True
524 chk (DictFunId _ _ _ _) = True
525 chk (ConstMethodId _ _ _ _ _) = True
526 chk (SpecId unspec _ _) = toplevelishId unspec
527 -- depends what the unspecialised thing is
528 chk (WorkerId unwrkr) = toplevelishId unwrkr
529 chk (InstId _) = False -- these are local
530 chk (LocalId _ _) = False
531 chk (SysLocalId _ _) = False
532 chk (SpecPragmaId _ _ _) = False
534 chk (ProcessorCon _ _) = True
535 chk (PodId _ _ id) = toplevelishId id
536 #endif {- Data Parallel Haskell -}
538 idHasNoFreeTyVars (Id _ _ info details)
541 chk (DataConId _ _ _ _ _ _) = True
542 chk (TupleConId _) = True
543 chk (ImportedId _) = True
544 chk (PreludeId _) = True
545 chk (TopLevId _) = True
546 chk (SuperDictSelId _ _) = True
547 chk (ClassOpId _ _) = True
548 chk (DefaultMethodId _ _ _) = True
549 chk (DictFunId _ _ _ _) = True
550 chk (ConstMethodId _ _ _ _ _) = True
551 chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
552 chk (InstId _) = False -- these are local
553 chk (SpecId _ _ no_free_tvs) = no_free_tvs
554 chk (LocalId _ no_free_tvs) = no_free_tvs
555 chk (SysLocalId _ no_free_tvs) = no_free_tvs
556 chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
558 chk (ProcessorCon _ _) = True
559 chk (PodId _ _ id) = idHasNoFreeTyVars id
560 #endif {- Data Parallel Haskell -}
564 isTopLevId (Id _ _ _ (TopLevId _)) = True
566 isTopLevId (PodId _ _ id) = isTopLevId id
567 #endif {- Data Parallel Haskell -}
568 isTopLevId other = False
570 -- an "invented" one is a top-level Id, must be globally visible, etc.,
571 -- but it's slightly different in that it was "conjured up".
572 -- This handles workers fine, but may need refinement for other
573 -- conjured-up things (e.g., specializations)
574 -- NB: Only used in DPH now (93/08/20)
578 isInventedTopLevId (TopLevId _ n _ _) = isInventedFullName n
579 isInventedTopLevId (SpecId _ _ _) = True
580 isInventedTopLevId (WorkerId _) = True
581 isInventedTopLevId (PodId _ _ id) = isInventedTopLevId id
582 isInventedTopLevId other = False
583 #endif {- Data Parallel Haskell -}
585 isImportedId (Id _ _ _ (ImportedId _)) = True
587 isImportedId (PodId _ _ id) = isImportedId id
588 #endif {- Data Parallel Haskell -}
589 isImportedId other = False
591 isBottomingId (Id _ _ info _) = bottomIsGuaranteed (getInfo info)
593 isBottomingId (PodId _ _ id) = isBottomingId id
594 #endif {- Data Parallel Haskell -}
595 --isBottomingId other = False
597 isSysLocalId (Id _ _ _ (SysLocalId _ _)) = True
599 isSysLocalId (PodId _ _ id) = isSysLocalId id
600 #endif {- Data Parallel Haskell -}
601 isSysLocalId other = False
603 isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _ _)) = True
605 isSpecPragmaId (PodId _ _ id) = isSpecPragmaId id
606 #endif {- Data Parallel Haskell -}
607 isSpecPragmaId other = False
609 isClassOpId (Id _ _ _ (ClassOpId _ _)) = True
610 isClassOpId _ = False
612 isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err)) = Just (cls, clsop, err)
614 isDefaultMethodId_maybe (PodId _ _ id) = isDefaultMethodId_maybe id
615 #endif {- Data Parallel Haskell -}
616 isDefaultMethodId_maybe other = Nothing
618 isDictFunId (Id _ _ _ (DictFunId _ _ _ _)) = True
620 isDictFunId (PodId _ _ id) = isDictFunId id
621 #endif {- Data Parallel Haskell -}
622 isDictFunId other = False
624 isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _ _)) = Just (cls, ty, clsop)
626 isConstMethodId_maybe (PodId _ _ id) = isConstMethodId_maybe id
627 #endif {- Data Parallel Haskell -}
628 isConstMethodId_maybe other = Nothing
630 isInstId_maybe (Id _ _ _ (InstId inst)) = Just inst
632 isInstId_maybe (PodId _ _ id) = isInstId_maybe id
633 #endif {- Data Parallel Haskell -}
634 isInstId_maybe other_id = Nothing
636 isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc)) = Just (c, sc)
638 isSuperDictSelId_maybe (PodId _ _ id) = isSuperDictSelId_maybe id
639 #endif {- Data Parallel Haskell -}
640 isSuperDictSelId_maybe other_id = Nothing
642 isWorkerId (Id _ _ _ (WorkerId _)) = True
644 isWorkerId (PodId _ _ id) = isWorkerId id
645 #endif {- Data Parallel Haskell -}
646 isWorkerId other = False
648 isWrapperId id = workerExists (getIdStrictness id)
652 pprIdInUnfolding :: IdSet -> Id -> Pretty
654 pprIdInUnfolding in_scopes v
656 v_ty = getIdUniType v
659 if v `elementOfUniqSet` in_scopes then
660 pprUnique (getTheUnique v)
662 -- ubiquitous Ids with special syntax:
663 else if v == nilDataCon then
665 else if isTupleCon v then
666 ppBeside (ppPStr SLIT("_TUP_")) (ppInt (getDataConArity v))
668 -- ones to think about:
671 (Id _ _ _ v_details) = v
674 -- these ones must have been exported by their original module
675 ImportedId _ -> pp_full_name
676 PreludeId _ -> pp_full_name
678 -- these ones' exportedness checked later...
679 TopLevId _ -> pp_full_name
680 DataConId _ _ _ _ _ _ -> pp_full_name
682 -- class-ish things: class already recorded as "mentioned"
684 -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
686 -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
687 DefaultMethodId c o _
688 -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
690 -- instance-ish things: should we try to figure out
691 -- *exactly* which extra instances have to be exported? (ToDo)
693 -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
694 ConstMethodId c t o _ _
695 -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
697 -- specialisations and workers
698 SpecId unspec ty_maybes _
700 pp = pprIdInUnfolding in_scopes unspec
702 ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
703 ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
708 pp = pprIdInUnfolding in_scopes unwrkr
710 ppBeside (ppPStr SLIT("_WRKR_ ")) pp
712 -- anything else? we're nae interested
713 other_id -> panic "pprIdInUnfolding:mystery Id"
715 ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
719 (m_str, n_str) = getOrigName v
722 if isAvarop n_str || isAconop n_str then
723 ppBesides [ppLparen, ppPStr n_str, ppRparen]
727 if fromPreludeCore v then
730 ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
732 pp_class :: Class -> Pretty
733 pp_class_op :: ClassOp -> Pretty
734 pp_type :: UniType -> Pretty
735 pp_ty_maybe :: Maybe UniType -> Pretty
737 pp_class clas = ppr ppr_Unfolding clas
738 pp_class_op op = ppr ppr_Unfolding op
740 pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
742 pp_ty_maybe Nothing = ppPStr SLIT("_N_")
743 pp_ty_maybe (Just t) = pp_type t
746 @whatsMentionedInId@ ferrets out the types/classes/instances on which
747 this @Id@ depends. If this Id is to appear in an interface, then
748 those entities had Jolly Well be in scope. Someone else up the
749 call-tree decides that.
753 :: IdSet -- Ids known to be in scope
754 -> Id -- Id being processed
755 -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
757 whatsMentionedInId in_scopes v
759 v_ty = getIdUniType v
762 = getMentionedTyConsAndClassesFromUniType v_ty
764 result0 id_bag = (id_bag, tycons, clss)
767 = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
768 tcs `unionBags` tycons,
772 if v `elementOfUniqSet` in_scopes then
773 result0 emptyBag -- v not added to "mentioned"
775 -- ones to think about:
778 (Id _ _ _ v_details) = v
781 -- specialisations and workers
782 SpecId unspec ty_maybes _
784 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
786 result1 ids2 tcs2 cs2
790 (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
792 result1 ids2 tcs2 cs2
794 anything_else -> result0 (unitBag v) -- v is added to "mentioned"
797 Tell them who my wrapper function is.
799 myWrapperMaybe :: Id -> Maybe Id
801 myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper)) = Just my_wrapper
802 myWrapperMaybe other_id = Nothing
806 unfoldingUnfriendlyId -- return True iff it is definitely a bad
807 :: Id -- idea to export an unfolding that
808 -> Bool -- mentions this Id. Reason: it cannot
809 -- possibly be seen in another module.
811 unfoldingUnfriendlyId id
812 | not (externallyVisibleId id) -- that settles that...
815 unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper))
816 = class_thing wrapper
818 -- "class thing": If we're going to use this worker Id in
819 -- an interface, we *have* to be able to untangle the wrapper's
820 -- strictness when reading it back in. At the moment, this
821 -- is not always possible: in precisely those cases where
822 -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
824 class_thing (Id _ _ _ (SuperDictSelId _ _)) = True
825 class_thing (Id _ _ _ (ClassOpId _ _)) = True
826 class_thing (Id _ _ _ (DefaultMethodId _ _ _)) = True
827 class_thing other = False
829 unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _))
830 -- a SPEC of a DictFunId can end up w/ gratuitous
831 -- TyVar(Templates) in the i/face; only a problem
832 -- if -fshow-pragma-name-errs; but we can do without the pain.
833 -- A HACK in any case (WDP 94/05/02)
834 = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
835 naughty_DictFunId dfun
838 unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _ _))
839 = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
840 naughty_DictFunId dfun -- similar deal...
843 unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
845 naughty_DictFunId :: IdDetails -> Bool
846 -- True <=> has a TyVar(Template) in the "type" part of its "name"
848 naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
849 naughty_DictFunId (DictFunId _ ty _ _)
850 = not (isGroundTy ty)
853 @externallyVisibleId@: is it true that another module might be
854 able to ``see'' this Id?
856 We need the @toplevelishId@ check as well as @isExported@ for when we
857 compile instance declarations in the prelude. @DictFunIds@ are
858 ``exported'' if either their class or tycon is exported, but, in
859 compiling the prelude, the compiler may not recognise that as true.
862 externallyVisibleId :: Id -> Bool
864 externallyVisibleId id@(Id _ _ _ details)
865 = if isLocallyDefined id then
866 toplevelishId id && isExported id && not (weird_datacon details)
868 not (weird_tuplecon details)
869 -- if visible here, it must be visible elsewhere, too.
871 -- If it's a DataCon, it's not enough to know it (meaning
872 -- its TyCon) is exported; we need to know that it might
873 -- be visible outside. Consider:
875 -- data Foo a = Mumble | BigFoo a WeirdLocalType
877 -- We can't tell the outside world *anything* about Foo, because
878 -- of WeirdLocalType; but we need to know this when asked if
879 -- "Mumble" is externally visible...
881 weird_datacon (DataConId _ _ _ _ _ tycon)
882 = maybeToBool (maybePurelyLocalTyCon tycon)
883 weird_datacon not_a_datacon_therefore_not_weird = False
885 weird_tuplecon (TupleConId arity)
886 = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
887 weird_tuplecon _ = False
891 idWantsToBeINLINEd :: Id -> Bool
893 idWantsToBeINLINEd id
894 = case (getIdUnfolding id) of
895 IWantToBeINLINEd _ -> True
899 For @unlocaliseId@: See the brief commentary in
900 \tr{simplStg/SimplStg.lhs}.
903 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
905 unlocaliseId mod (Id u ty info (TopLevId fn))
906 = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
908 unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
909 = --false?: ASSERT(no_ftvs)
911 full_name = unlocaliseShortName mod u sn
913 Just (Id u ty info (TopLevId full_name))
915 unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
916 = --false?: on PreludeGlaST: ASSERT(no_ftvs)
918 full_name = unlocaliseShortName mod u sn
920 Just (Id u ty info (TopLevId full_name))
922 unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
923 = case unlocalise_parent mod u unspec of
925 Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))
927 unlocaliseId mod (Id u ty info (WorkerId unwrkr))
928 = case unlocalise_parent mod u unwrkr of
930 Just xx -> Just (Id u ty info (WorkerId xx))
932 unlocaliseId mod (Id u ty info (InstId inst))
933 = Just (Id u ty info (TopLevId full_name))
934 -- type might be wrong, but it hardly matters
935 -- at this stage (just before printing C) ToDo
937 name = let (bit1:bits) = getInstNamePieces True inst in
938 _CONCAT_ (bit1 : [ _CONS_ '.' b | b <- bits ])
940 full_name = mkFullName mod (mod _APPEND_ name) InventedInThisModule ExportAll mkGeneratedSrcLoc
943 unlocaliseId mod (PodId dim ity id)
944 = case (unlocaliseId mod id) of
945 Just id' -> Just (PodId dim ity id')
947 #endif {- Data Parallel Haskell -}
949 unlocaliseId mod other_id = Nothing
952 -- we have to be Very Careful for workers/specs of
955 unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs))
956 = --false?: ASSERT(no_ftvs)
958 full_name = unlocaliseShortName mod uniq sn
960 Just (Id uniq ty info (TopLevId full_name))
962 unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
963 = --false?: ASSERT(no_ftvs)
965 full_name = unlocaliseShortName mod uniq sn
967 Just (Id uniq ty info (TopLevId full_name))
969 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
970 -- we're OK otherwise
973 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
974 `Top-levelish Ids'' cannot have any free type variables, so applying
975 the type-env cannot have any effect. (NB: checked in CoreLint?)
977 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
978 former ``should be'' the usual crunch point.
981 applyTypeEnvToId :: TypeEnv -> Id -> Id
983 applyTypeEnvToId type_env id@(Id u ty info details)
984 | idHasNoFreeTyVars id
987 = apply_to_Id ( \ ty ->
988 applyTypeEnvToTy type_env ty
993 apply_to_Id :: (UniType -> UniType)
997 apply_to_Id ty_fn (Id u ty info details)
998 = Id u (ty_fn ty) (apply_to_IdInfo ty_fn info) (apply_to_details details)
1000 apply_to_details (InstId inst)
1002 new_inst = apply_to_Inst ty_fn inst
1006 apply_to_details (SpecId unspec ty_maybes no_ftvs)
1008 new_unspec = apply_to_Id ty_fn unspec
1009 new_maybes = map apply_to_maybe ty_maybes
1011 SpecId new_unspec new_maybes no_ftvs
1012 -- ToDo: recalc no_ftvs????
1014 apply_to_maybe Nothing = Nothing
1015 apply_to_maybe (Just ty) = Just (ty_fn ty)
1017 apply_to_details (WorkerId unwrkr)
1019 new_unwrkr = apply_to_Id ty_fn unwrkr
1024 apply_to_details (PodId d ity id )
1025 = PodId d ity (apply_to_Id ty_fn id)
1026 #endif {- Data Parallel Haskell -}
1028 apply_to_details other = other
1031 Sadly, I don't think the one using the magic typechecker substitution
1032 can be done with @apply_to_Id@. Here we go....
1034 Strictness is very important here. We can't leave behind thunks
1035 with pointers to the substitution: it {\em must} be single-threaded.
1038 applySubstToId :: Subst -> Id -> (Subst, Id)
1040 applySubstToId subst id@(Id u ty info details)
1041 -- *cannot* have a "idHasNoFreeTyVars" get-out clause
1042 -- because, in the typechecker, we are still
1043 -- *concocting* the types.
1044 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
1045 case (applySubstToIdInfo s2 info) of { (s3, new_info) ->
1046 case (apply_to_details s3 new_ty details) of { (s4, new_details) ->
1047 (s4, Id u new_ty new_info new_details) }}}
1049 apply_to_details subst _ (InstId inst)
1050 = case (applySubstToInst subst inst) of { (s2, new_inst) ->
1051 (s2, InstId new_inst) }
1053 apply_to_details subst new_ty (SpecId unspec ty_maybes _)
1054 = case (applySubstToId subst unspec) of { (s2, new_unspec) ->
1055 case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
1056 (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
1057 -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
1059 apply_to_maybe subst Nothing = (subst, Nothing)
1060 apply_to_maybe subst (Just ty)
1061 = case (applySubstToTy subst ty) of { (s2, new_ty) ->
1064 apply_to_details subst _ (WorkerId unwrkr)
1065 = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
1066 (s2, WorkerId new_unwrkr) }
1068 apply_to_details subst _ other = (subst, other)
1071 applySubstToId (PodId d ity id )
1072 = ???? ToDo:DPH; not sure what! returnLft (PodId d ity (applySubstToId id))
1073 #endif {- Data Parallel Haskell -}
1077 getIdNamePieces :: Bool {-show Uniques-} -> Id -> [FAST_STRING]
1079 getIdNamePieces show_uniqs (Id u ty info details)
1081 DataConId n _ _ _ _ _ ->
1082 case (getOrigName n) of { (mod, name) ->
1083 if fromPrelude mod then [name] else [mod, name] }
1085 TupleConId a -> [SLIT("Tup") _APPEND_ (_PK_ (show a))]
1087 ImportedId n -> get_fullname_pieces n
1088 PreludeId n -> get_fullname_pieces n
1089 TopLevId n -> get_fullname_pieces n
1091 SuperDictSelId c sc ->
1092 case (getOrigName c) of { (c_mod, c_name) ->
1093 case (getOrigName sc) of { (sc_mod, sc_name) ->
1095 c_bits = if fromPreludeCore c
1097 else [c_mod, c_name]
1099 sc_bits= if fromPreludeCore sc
1101 else [sc_mod, sc_name]
1103 [SLIT("sdsel")] ++ c_bits ++ sc_bits }}
1105 ClassOpId clas op ->
1106 case (getOrigName clas) of { (c_mod, c_name) ->
1107 case (getClassOpString op) of { op_name ->
1108 if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name]
1111 DefaultMethodId clas op _ ->
1112 case (getOrigName clas) of { (c_mod, c_name) ->
1113 case (getClassOpString op) of { op_name ->
1114 if fromPreludeCore clas
1115 then [SLIT("defm"), op_name]
1116 else [SLIT("defm"), c_mod, c_name, op_name] }}
1118 DictFunId c ty _ _ ->
1119 case (getOrigName c) of { (c_mod, c_name) ->
1121 c_bits = if fromPreludeCore c
1123 else [c_mod, c_name]
1125 ty_bits = getTypeString ty
1127 [SLIT("dfun")] ++ c_bits ++ ty_bits }
1130 ConstMethodId c ty o _ _ ->
1131 case (getOrigName c) of { (c_mod, c_name) ->
1132 case (getTypeString ty) of { ty_bits ->
1133 case (getClassOpString o) of { o_name ->
1134 case (if fromPreludeCore c
1136 else [c_mod, c_name]) of { c_bits ->
1137 [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
1139 -- if the unspecialised equiv is "top-level",
1140 -- the name must be concocted from its name and the
1141 -- names of the types to which specialised...
1143 SpecId unspec ty_maybes _ ->
1144 getIdNamePieces show_uniqs unspec ++ (
1145 if not (toplevelishId unspec)
1147 else concat (map typeMaybeString ty_maybes)
1151 getIdNamePieces show_uniqs unwrkr ++ (
1152 if not (toplevelishId unwrkr)
1154 else [SLIT("wrk")] -- show u
1157 InstId inst -> getInstNamePieces show_uniqs inst
1158 LocalId n _ -> let local = getLocalName n in
1159 if show_uniqs then [local, showUnique u] else [local]
1160 SysLocalId n _ -> [getLocalName n, showUnique u]
1161 SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
1164 ProcessorCon a _ -> ["MkProcessor" ++ (show a)]
1165 PodId n ity id -> getIdNamePieces show_uniqs id ++
1166 ["mapped", "POD" ++ (show n), show ity]
1167 #endif {- Data Parallel Haskell -}
1169 get_fullname_pieces :: FullName -> [FAST_STRING]
1170 get_fullname_pieces n
1171 = BIND (getOrigName n) _TO_ (mod, name) ->
1178 Really Inst-ish, but only used in this module...
1180 getInstNamePieces :: Bool -> Inst -> [FAST_STRING]
1182 getInstNamePieces show_uniqs (Dict u clas ty _)
1183 = let (mod, nm) = getOrigName clas in
1184 if fromPreludeCore clas
1185 then [SLIT("d"), nm, showUnique u]
1186 else [SLIT("d"), mod, nm, showUnique u]
1188 getInstNamePieces show_uniqs (Method u id tys _)
1189 = let local = getIdNamePieces show_uniqs id in
1190 if show_uniqs then local ++ [showUnique u] else local
1192 getInstNamePieces show_uniqs (LitInst u _ _ _) = [SLIT("lit"), showUnique u]
1195 %************************************************************************
1197 \subsection[Id-type-funs]{Type-related @Id@ functions}
1199 %************************************************************************
1202 getIdUniType :: Id -> UniType
1204 getIdUniType (Id _ ty _ _) = ty
1208 getIdUniType (ProcessorCon _ ty) = ty
1209 getIdUniType (PodId d ity id)
1210 = let (foralls,rho) = splitForalls (getIdUniType id) in
1211 let tys = get_args rho in
1212 let itys_mask = infoTypeNumToMask ity in
1213 let tys' = zipWith convert tys itys_mask in
1214 mkForallTy foralls (foldr1 mkFunTy tys')
1215 where -- ToDo(hilly) change to use getSourceType etc...
1217 get_args ty = case (maybeUnpackFunTy ty) of
1219 Just (arg,res) -> arg:get_args res
1221 convert ty cond = if cond
1225 coerce ty = case (maybeUnpackFunTy ty) of
1226 Nothing ->mkPodizedPodNTy d ty
1227 Just (arg,res) ->mkFunTy (coerce arg) (coerce res)
1228 #endif {- Data Parallel Haskell -}
1232 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1234 getMentionedTyConsAndClassesFromId id
1235 = getMentionedTyConsAndClassesFromUniType (getIdUniType id)
1239 getIdKind i = kindFromType (getIdUniType i)
1243 getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
1244 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
1245 getInstIdModule other = panic "Id:getInstIdModule"
1251 getIdTauType :: Id -> TauType
1252 getIdTauType i = expandTySyn (getTauType (getIdUniType i))
1254 getIdSourceTypes :: Id -> [TauType]
1255 getIdSourceTypes i = map expandTySyn (sourceTypes (getTauType (getIdUniType i)))
1257 getIdTargetType :: Id -> TauType
1258 getIdTargetType i = expandTySyn (targetType (getTauType (getIdUniType i)))
1262 %************************************************************************
1264 \subsection[Id-overloading]{Functions related to overloading}
1266 %************************************************************************
1269 mkSuperDictSelId u c sc ty info = Id u ty info (SuperDictSelId c sc)
1270 mkClassOpId u c op ty info = Id u ty info (ClassOpId c op)
1271 mkDefaultMethodId u c op gen ty info = Id u ty info (DefaultMethodId c op gen)
1273 mkDictFunId u c ity full_ty from_here modname info
1274 = Id u full_ty info (DictFunId c ity from_here modname)
1276 mkConstMethodId u c op ity full_ty from_here modname info
1277 = Id u full_ty info (ConstMethodId c ity op from_here modname)
1279 mkWorkerId u unwrkr ty info = Id u ty info (WorkerId unwrkr)
1282 = Id u (getInstUniType inst) noIdInfo (InstId inst)
1286 Method u i ts o -> u
1287 LitInst u l ty o -> u
1290 getSuperDictSelIdSig (Id _ _ _ (SuperDictSelId input_class result_class))
1291 = (input_class, result_class)
1295 %************************************************************************
1297 \subsection[local-funs]{@LocalId@-related functions}
1299 %************************************************************************
1302 mkImported u n ty info = Id u ty info (ImportedId n)
1303 mkPreludeId u n ty info = Id u ty info (PreludeId n)
1306 mkPodId d i = PodId d i
1309 updateIdType :: Id -> UniType -> Id
1310 updateIdType (Id u _ info details) ty = Id u ty info details
1314 no_free_tvs ty = null (extractTyVarsFromTy ty)
1316 -- SysLocal: for an Id being created by the compiler out of thin air...
1317 -- UserLocal: an Id with a name the user might recognize...
1318 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> UniType -> SrcLoc -> Id
1320 mkSysLocal str uniq ty loc
1321 = Id uniq ty noIdInfo (SysLocalId (mkShortName str loc) (no_free_tvs ty))
1323 mkUserLocal str uniq ty loc
1324 = Id uniq ty noIdInfo (LocalId (mkShortName str loc) (no_free_tvs ty))
1326 -- for a SpecPragmaId being created by the compiler out of thin air...
1327 mkSpecPragmaId :: FAST_STRING -> Unique -> UniType -> Maybe SpecInfo -> SrcLoc -> Id
1328 mkSpecPragmaId str uniq ty specinfo loc
1329 = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specinfo (no_free_tvs ty))
1332 mkSpecId u unspec ty_maybes ty info
1333 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1334 Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1336 -- Specialised version of constructor: only used in STG and code generation
1337 -- Note: The specialsied Id has the same unique as the unspeced Id
1339 mkSameSpecCon ty_maybes unspec@(Id u ty info details)
1340 = ASSERT(isDataCon unspec)
1341 ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1342 Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1344 new_ty = specialiseTy ty ty_maybes 0
1346 -- pprTrace "SameSpecCon:Unique:"
1347 -- (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes]))
1349 -- mkId builds a local or top-level Id, depending on the name given
1350 mkId :: Name -> UniType -> IdInfo -> Id
1351 mkId (Short uniq short) ty info = Id uniq ty info (LocalId short (no_free_tvs ty))
1352 mkId (OtherTopId uniq full) ty info
1354 (if isLocallyDefined full then TopLevId full else ImportedId full)
1356 localiseId :: Id -> Id
1357 localiseId id@(Id u ty info details)
1358 = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
1360 name = getOccurrenceName id
1363 -- this has to be one of the "local" flavours (LocalId, SysLocalId, InstId)
1364 -- ToDo: it does??? WDP
1365 mkIdWithNewUniq :: Id -> Unique -> Id
1367 mkIdWithNewUniq (Id _ ty info details) uniq
1371 InstId (Dict _ c t o) -> InstId (Dict uniq c t o)
1372 InstId (Method _ i ts o) -> InstId (Method uniq i ts o)
1373 InstId (LitInst _ l ty o) -> InstId (LitInst uniq l ty o)
1374 old_details -> old_details
1376 Id uniq ty info new_details
1379 mkIdWithNewUniq (PodId d t id) uniq = PodId d t (mkIdWithNewUniq id uniq)
1380 #endif {- Data Parallel Haskell -}
1383 Make some local @Ids@ for a template @CoreExpr@. These have bogus
1384 @Uniques@, but that's OK because the templates are supposed to be
1385 instantiated before use.
1387 mkTemplateLocals :: [UniType] -> [Id]
1388 mkTemplateLocals tys
1389 = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc)
1390 (getBuiltinUniques (length tys))
1395 getIdInfo :: Id -> IdInfo
1397 getIdInfo (Id _ _ info _) = info
1400 getIdInfo (PodId _ _ id) = getIdInfo id
1401 #endif {- Data Parallel Haskell -}
1403 replaceIdInfo :: Id -> IdInfo -> Id
1405 replaceIdInfo (Id u ty _ details) info = Id u ty info details
1408 replaceIdInfo (PodId dim ity id) info = PodId dim ity (replaceIdInfo id info)
1409 #endif {- Data Parallel Haskell -}
1411 selectIdInfoForSpecId :: Id -> IdInfo
1412 selectIdInfoForSpecId unspec
1413 = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1414 noIdInfo `addInfo_UF` getIdUnfolding unspec
1417 %************************************************************************
1419 \subsection[Id-arities]{Arity-related functions}
1421 %************************************************************************
1423 For locally-defined Ids, the code generator maintains its own notion
1424 of their arities; so it should not be asking... (but other things
1425 besides the code-generator need arity info!)
1428 getIdArity :: Id -> ArityInfo
1429 getDataConArity :: DataCon -> Int -- a simpler i/face; they always have arities
1432 getIdArity (ProcessorCon n _) = mkArityInfo n
1433 getIdArity (PodId _ _ id) = getIdArity id
1434 #endif {- Data Parallel Haskell -}
1436 getIdArity (Id _ _ id_info _) = getInfo id_info
1438 getDataConArity id@(Id _ _ id_info _)
1439 = ASSERT(isDataCon id)
1440 case (arityMaybe (getInfo id_info)) of
1441 Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id)
1444 addIdArity :: Id -> Int -> Id
1445 addIdArity (Id u ty info details) arity
1446 = Id u ty (info `addInfo` (mkArityInfo arity)) details
1449 %************************************************************************
1451 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1453 %************************************************************************
1456 mkDataCon :: Unique{-DataConKey-} -> FullName -> [TyVarTemplate] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
1457 -- can get the tag and all the pieces of the type from the UniType
1459 mkDataCon k n tyvar_tmpls context args_tys tycon specenv = data_con
1461 data_con = Id k type_of_constructor datacon_info
1463 (position_within fIRST_TAG data_con_family data_con)
1464 tyvar_tmpls context args_tys tycon)
1466 -- Note data_con self-recursion;
1467 -- should be OK as tags are not looked at until
1468 -- late in the game.
1470 data_con_family = getTyConDataCons tycon
1472 position_within :: Int -> [Id] -> Id -> Int
1473 position_within acc [] con
1474 = panic "mkDataCon: con not found in family"
1476 position_within acc (c:cs) con
1477 = if c `eqId` con then acc else position_within (acc+(1::Int)) cs con
1479 type_of_constructor = mkSigmaTy tyvar_tmpls context
1482 (applyTyCon tycon (map mkTyVarTemplateTy tyvar_tmpls)))
1484 datacon_info = noIdInfo `addInfo_UF` unfolding
1485 `addInfo` mkArityInfo arity
1488 arity = length args_tys
1493 -- else -- do some business...
1495 (tyvars, dict_vars, vars) = mk_uf_bits tyvar_tmpls context args_tys tycon
1496 tyvar_tys = map mkTyVarTy tyvars
1498 BIND (CoCon data_con tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon ->
1500 BIND (mkCoLam (dict_vars ++ vars) plain_CoCon) _TO_ lambdized_CoCon ->
1502 mkUnfolding EssentialUnfolding -- for data constructors
1503 (foldr CoTyLam lambdized_CoCon tyvars)
1506 mk_uf_bits tyvar_tmpls context arg_tys tycon
1508 (inst_env, tyvars, tyvar_tys)
1509 = instantiateTyVarTemplates tyvar_tmpls
1510 (map getTheUnique tyvar_tmpls)
1512 -- the "context" and "arg_tys" have TyVarTemplates in them, so
1513 -- we instantiate those types to have the right TyVars in them
1515 BIND (map (instantiateTauTy inst_env) (map ctxt_ty context))
1516 _TO_ inst_dict_tys ->
1517 BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys ->
1519 -- We can only have **ONE** call to mkTemplateLocals here;
1520 -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1521 -- (Mega-Sigh) [ToDo]
1522 BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
1524 BIND (splitAt (length context) all_vars) _TO_ (dict_vars, vars) ->
1526 (tyvars, dict_vars, vars)
1529 -- these are really dubious UniTypes, but they are only to make the
1530 -- binders for the lambdas for tossed-away dicts.
1531 ctxt_ty (clas, ty) = mkDictTy clas ty
1535 mkTupleCon :: Arity -> Id
1537 mkTupleCon arity = data_con
1539 data_con = Id unique ty tuplecon_info (TupleConId arity)
1540 unique = mkTupleDataConUnique arity
1541 ty = mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys))
1542 tycon = mkTupleTyCon arity
1543 tyvars = take arity alphaTyVars
1544 tyvar_tys = map mkTyVarTemplateTy tyvars
1547 = noIdInfo `addInfo_UF` unfolding
1548 `addInfo` mkArityInfo arity
1549 `addInfo` pcGenerateTupleSpecs arity ty
1554 -- else -- do some business...
1556 (tyvars, dict_vars, vars) = mk_uf_bits arity
1557 tyvar_tys = map mkTyVarTy tyvars
1559 BIND (CoCon data_con tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon ->
1561 BIND (mkCoLam (dict_vars ++ vars) plain_CoCon) _TO_ lambdized_CoCon ->
1564 EssentialUnfolding -- data constructors
1565 (foldr CoTyLam lambdized_CoCon tyvars)
1569 = BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
1573 tyvar_tmpls = take arity alphaTyVars
1574 (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getTheUnique tyvar_tmpls)
1578 mkProcessorCon :: Arity -> Id
1579 mkProcessorCon arity
1580 = ProcessorCon arity ty
1582 ty = mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys))
1583 tycon = mkProcessorTyCon arity
1584 tyvars = take arity alphaTyVars
1585 tyvar_tys = map mkTyVarTemplateTy tyvars
1586 #endif {- Data Parallel Haskell -}
1589 fIRST_TAG = 1 -- Tags allocated from here for real constructors
1591 -- given one data constructor in a family, return a list
1592 -- of all the data constructors in that family.
1595 getDataConFamily :: DataCon -> [DataCon]
1597 getDataConFamily data_con
1598 = ASSERT(isDataCon data_con)
1599 getTyConDataCons (getDataConTyCon data_con)
1604 getDataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1606 getDataConTag (Id _ _ _ (DataConId _ tag _ _ _ _)) = tag
1607 getDataConTag (Id _ _ _ (TupleConId _)) = fIRST_TAG
1608 getDataConTag (Id _ _ _ (SpecId unspec _ _)) = getDataConTag unspec
1610 getDataConTag (ProcessorCon _ _) = fIRST_TAG
1611 #endif {- Data Parallel Haskell -}
1613 getDataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
1615 getDataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ tycon)) = tycon
1616 getDataConTyCon (Id _ _ _ (TupleConId a)) = mkTupleTyCon a
1617 getDataConTyCon (Id _ _ _ (SpecId unspec tys _)) = mkSpecTyCon (getDataConTyCon unspec) tys
1619 getDataConTyCon (ProcessorCon a _) = mkProcessorTyCon a
1620 #endif {- Data Parallel Haskell -}
1622 getDataConSig :: DataCon -> ([TyVarTemplate], ThetaType, [TauType], TyCon)
1623 -- will panic if not a DataCon
1625 getDataConSig (Id _ _ _ (DataConId _ _ tyvars theta_ty arg_tys tycon))
1626 = (tyvars, theta_ty, arg_tys, tycon)
1628 getDataConSig (Id _ _ _ (TupleConId arity))
1629 = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1631 tyvars = take arity alphaTyVars
1632 tyvar_tys = map mkTyVarTemplateTy tyvars
1634 getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
1635 = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
1637 (tyvars, theta_ty, arg_tys, tycon) = getDataConSig unspec
1639 ty_env = tyvars `zip` ty_maybes
1641 spec_tyvars = foldr nothing_tyvars [] ty_env
1642 nothing_tyvars (tyvar, Nothing) l = tyvar : l
1643 nothing_tyvars (tyvar, Just ty) l = l
1645 spec_env = foldr just_env [] ty_env
1646 just_env (tyvar, Nothing) l = l
1647 just_env (tyvar, Just ty) l = (tyvar, ty) : l
1648 spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
1650 spec_theta_ty = if null theta_ty then []
1651 else panic "getDataConSig:ThetaTy:SpecDataCon"
1652 spec_tycon = mkSpecTyCon tycon ty_maybes
1655 getDataConSig (ProcessorCon arity _)
1656 = (tyvars, [], tyvar_tys, mkProcessorTyCon arity)
1658 tyvars = take arity alphaTyVars
1659 tyvar_tys = map mkTyVarTemplateTy tyvars
1660 #endif {- Data Parallel Haskell -}
1663 @getInstantiatedDataConSig@ takes a constructor and some types to which
1664 it is applied; it returns its signature instantiated to these types.
1667 getInstantiatedDataConSig ::
1668 DataCon -- The data constructor
1669 -- Not a specialised data constructor
1670 -> [TauType] -- Types to which applied
1671 -- Must be fully applied i.e. contain all types of tycon
1672 -> ([TauType], -- Types of dict args
1673 [TauType], -- Types of regular args
1674 TauType -- Type of result
1677 getInstantiatedDataConSig data_con tycon_arg_tys
1678 = ASSERT(isDataCon data_con)
1679 --false?? WDP 95/06: ASSERT(not (maybeToBool (isSpecId_maybe data_con)))
1681 (tv_tmpls, theta, cmpnt_ty_tmpls, tycon) = getDataConSig data_con
1683 inst_env = --ASSERT(length tv_tmpls == length tycon_arg_tys)
1684 {- if (length tv_tmpls /= length tycon_arg_tys) then
1685 pprPanic "Id:1666:" (ppCat [ppr PprShowAll data_con, ppr PprDebug tycon_arg_tys])
1687 -} tv_tmpls `zip` tycon_arg_tys
1689 theta_tys = [ instantiateTauTy inst_env (mkDictTy c t) | (c,t) <- theta ]
1690 cmpnt_tys = map (instantiateTauTy inst_env) cmpnt_ty_tmpls
1691 result_ty = instantiateTauTy inst_env (applyTyCon tycon tycon_arg_tys)
1693 -- Are the first/third results ever used?
1694 (theta_tys, cmpnt_tys, result_ty)
1696 {- UNUSED: allows a specilaised constructor to be instantiated
1697 (with all argument types of the unspecialsied tycon)
1699 getInstantiatedDataConSig data_con tycon_arg_tys
1700 = ASSERT(isDataCon data_con)
1701 if is_speccon && arg_tys_match_error then
1702 pprPanic "getInstantiatedDataConSig:SpecId:"
1703 (ppHang (ppr PprDebug data_con) 4 pp_match_error)
1705 (theta_tys, cmpnt_tys, result_ty) -- Are the first/third results ever used?
1707 is_speccon = maybeToBool is_speccon_maybe
1708 is_speccon_maybe = isSpecId_maybe data_con
1709 Just (unspec_con, spec_tys) = is_speccon_maybe
1711 arg_tys_match_error = maybeToBool match_error_maybe
1712 match_error_maybe = ASSERT(length spec_tys == length tycon_arg_tys)
1713 argTysMatchSpecTys spec_tys tycon_arg_tys
1714 (Just pp_match_error) = match_error_maybe
1716 (tv_tmpls, theta, cmpnt_ty_tmpls, tycon)
1718 then getDataConSig unspec_con
1719 else getDataConSig data_con
1721 inst_env = ASSERT(length tv_tmpls == length tycon_arg_tys)
1722 tv_tmpls `zip` tycon_arg_tys
1724 theta_tys = [ instantiateTauTy inst_env (mkDictTy c t) | (c,t) <- theta ]
1725 cmpnt_tys = map (instantiateTauTy inst_env) cmpnt_ty_tmpls
1726 result_ty = instantiateTauTy inst_env (applyTyCon tycon tycon_arg_tys)
1730 The function @getDataConDeps@ is passed an @Id@ representing a data
1731 constructor of some type. We look at the source types of the
1732 constructor and create the set of all @TyCons@ referred to directly
1733 from the source types.
1736 #ifdef USE_SEMANTIQUE_STRANAL
1737 getDataConDeps :: Id -> [TyCon]
1739 getDataConDeps (Id _ _ _ (DataConId _ _ _ _ arg_tys _))
1740 = concat (map getReferredToTyCons arg_tys)
1741 getDataConDeps (Id _ _ _ (TupleConId _)) = []
1742 getDataConDeps (Id _ _ _ (SpecId unspec ty_maybes _))
1743 = getDataConDeps unspec ++ concat (map getReferredToTyCons (catMaybes ty_maybes))
1745 getDataConDeps (ProcessorCon _ _) = []
1746 #endif {- Data Parallel Haskell -}
1747 #endif {- Semantique strictness analyser -}
1750 Data type declarations are of the form:
1752 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1754 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1755 @C1 x y z@, we want a function binding:
1757 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> CoCon C1 [a, b] [x, y, z]
1759 Notice the ``big lambdas'' and type arguments to @CoCon@---we are producing
1760 2nd-order polymorphic lambda calculus with explicit types.
1762 %************************************************************************
1764 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1766 %************************************************************************
1768 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1769 and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
1770 @TyVars@ don't really have to be new, because we are only producing a
1773 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1776 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1777 EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the
1778 example above: a, b, and x, y, z], which is enough (in the important
1779 \tr{DsExpr} case). (The middle set of @Ids@ is binders for any
1780 dictionaries, in the even of an overloaded data-constructor---none at
1784 getIdUnfolding :: Id -> UnfoldingDetails
1787 getIdUnfolding dcon@(ProcessorCon arity _)
1789 (tyvars, dict_vars, vars) = getDataConUnfolding dcon
1790 tyvar_tys = map mkTyVarTy tyvars
1792 BIND (CoCon dcon tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon ->
1793 BIND (mkCoLam vars plain_CoCon) _TO_ lambdized_CoCon ->
1794 mkUnfoldTemplate (\x->False){-ToDo-} EssentialUnfolding{-ToDo???DPH-} (foldr CoTyLam lambdized_CoCon tyvars)
1797 -- If we have a PodId whose ``id'' has an unfolding, then we need to
1798 -- parallelize the unfolded expression for the d^th dimension.
1800 getIdUnfolding (PodId d _ id)
1801 = case (unfoldingMaybe (getIdUnfolding id)) of
1803 Just expr -> trace ("getIdUnfolding ("++
1804 ppShow 80 (ppr PprDebug id) ++
1805 ") for " ++ show d ++ "D pod")
1806 (podizeTemplateExpr d expr)
1808 #endif {- Data Parallel Haskell -}
1810 getIdUnfolding (Id _ _ id_info _) = getInfo_UF id_info
1812 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1813 addIdUnfolding id@(Id u ty info details) unfold_details
1815 case (isLocallyDefined id, unfold_details) of
1816 (_, NoUnfoldingDetails) -> True
1817 (True, IWantToBeINLINEd _) -> True
1818 (False, IWantToBeINLINEd _) -> False -- v bad
1822 Id u ty (info `addInfo_UF` unfold_details) details
1825 clearIdUnfolding :: Id -> Id
1826 clearIdUnfolding (Id u ty info details) = Id u ty (clearInfo_UF info) details
1830 In generating selector functions (take a dictionary, give back one
1831 component...), we need to what out for the nothing-to-select cases (in
1832 which case the ``selector'' is just an identity function):
1834 class Eq a => Foo a { } # the superdict selector for "Eq"
1836 class Foo a { op :: Complex b => c -> b -> a }
1837 # the method selector for "op";
1838 # note local polymorphism...
1841 For data constructors, we make an unfolding which has a bunch of
1842 lambdas to bind the arguments, with a (saturated) @CoCon@ inside. In
1843 the case of overloaded constructors, the dictionaries are just thrown
1844 away; they were only required in the first place to ensure that the
1845 type was indeed an instance of the required class.
1848 getDataConUnfolding :: Id -> ([TyVar], [Id], [Id])
1850 getDataConUnfolding dcon@(ProcessorCon arity _)
1851 = BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
1855 tyvar_tmpls = take arity alphaTyVars
1856 (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getTheUnique tyvar_tmpls)
1857 #endif {- Data Parallel Haskell -}
1860 %************************************************************************
1862 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1864 %************************************************************************
1867 getIdDemandInfo :: Id -> DemandInfo
1868 getIdDemandInfo (Id _ _ info _) = getInfo info
1870 addIdDemandInfo :: Id -> DemandInfo -> Id
1871 addIdDemandInfo (Id u ty info details) demand_info
1872 = Id u ty (info `addInfo` demand_info) details
1876 getIdUpdateInfo :: Id -> UpdateInfo
1877 getIdUpdateInfo (Id u ty info details) = getInfo info
1879 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1880 addIdUpdateInfo (Id u ty info details) upd_info
1881 = Id u ty (info `addInfo` upd_info) details
1885 getIdArgUsageInfo :: Id -> ArgUsageInfo
1886 getIdArgUsageInfo (Id u ty info details) = getInfo info
1888 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1889 addIdArgUsageInfo (Id u ty info details) au_info
1890 = Id u ty (info `addInfo` au_info) details
1894 getIdFBTypeInfo :: Id -> FBTypeInfo
1895 getIdFBTypeInfo (Id u ty info details) = getInfo info
1897 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1898 addIdFBTypeInfo (Id u ty info details) upd_info
1899 = Id u ty (info `addInfo` upd_info) details
1903 getIdSpecialisation :: Id -> SpecEnv
1904 getIdSpecialisation (Id _ _ info _) = getInfo info
1906 addIdSpecialisation :: Id -> SpecEnv -> Id
1907 addIdSpecialisation (Id u ty info details) spec_info
1908 = Id u ty (info `addInfo` spec_info) details
1911 Strictness: we snaffle the info out of the IdInfo.
1914 getIdStrictness :: Id -> StrictnessInfo
1916 getIdStrictness (Id _ _ id_info _) = getInfo id_info
1918 addIdStrictness :: Id -> StrictnessInfo -> Id
1920 addIdStrictness (Id u ty info details) strict_info
1921 = Id u ty (info `addInfo` strict_info) details
1924 %************************************************************************
1926 \subsection[Id-comparison]{Comparison functions for @Id@s}
1928 %************************************************************************
1930 Comparison: equality and ordering---this stuff gets {\em hammered}.
1933 cmpId (Id u1 _ _ _) (Id u2 _ _ _) = cmpUnique u1 u2
1934 -- short and very sweet
1938 eqId :: Id -> Id -> Bool
1940 eqId a b = case cmpId a b of { EQ_ -> True; _ -> False }
1942 instance Eq Id where
1943 a == b = case cmpId a b of { EQ_ -> True; _ -> False }
1944 a /= b = case cmpId a b of { EQ_ -> False; _ -> True }
1946 instance Ord Id where
1947 a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
1948 a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
1949 a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
1950 a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
1951 #ifdef __GLASGOW_HASKELL__
1952 _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1956 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1957 account when comparing two data constructors. We need to do this
1958 because a specialsied data constructor has the same unique as its
1959 unspeciailsed counterpart.
1962 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1964 cmpId_withSpecDataCon id1 id2
1965 | eq_ids && isDataCon id1 && isDataCon id2
1966 = cmpEqDataCon id1 id2
1971 cmp_ids = cmpId id1 id2
1972 eq_ids = case cmp_ids of { EQ_ -> True; other -> False }
1974 cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _)) (Id _ _ _ (SpecId _ mtys2 _))
1975 = cmpUniTypeMaybeList mtys1 mtys2
1977 cmpEqDataCon unspec1 (Id _ _ _ (SpecId _ _ _))
1980 cmpEqDataCon (Id _ _ _ (SpecId _ _ _)) unspec2
1983 cmpEqDataCon unspec1 unspec2
1988 %************************************************************************
1990 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1992 %************************************************************************
1995 instance Outputable Id where
1996 ppr sty id = pprId sty id
1998 showId :: PprStyle -> Id -> String
1999 showId sty id = ppShow 80 (pprId sty id)
2002 -- for DictFuns (instances) and const methods (instance code bits we
2003 -- can call directly): exported (a) if *either* the class or
2004 -- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
2005 -- class and tycon are from PreludeCore [non-std, but convenient]
2006 -- *and* the thing was defined in this module.
2008 instance_export_flag :: Class -> UniType -> Bool -> ExportFlag
2010 instance_export_flag clas inst_ty from_here
2011 = if instanceIsExported clas inst_ty from_here
2016 Do we consider an ``instance type'' (as on a @DictFunId@) to be ``from
2017 PreludeCore''? True if the outermost TyCon is fromPreludeCore.
2019 is_prelude_core_ty :: UniType -> Bool
2021 is_prelude_core_ty inst_ty
2022 = case getUniDataTyCon_maybe inst_ty of
2023 Just (tycon,_,_) -> fromPreludeCore tycon
2024 Nothing -> panic "Id: is_prelude_core_ty"
2027 Default printing code (not used for interfaces):
2029 pprId :: PprStyle -> Id -> Pretty
2033 pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
2037 pieces_to_print -- maybe use Unique only
2038 = if isSysLocalId id then tail pieces else pieces
2040 ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
2043 PprForC _ -> for_code
2044 PprForAsm _ _ _ -> for_code
2045 PprInterface _ -> ppPStr occur_name
2046 PprForUser -> ppPStr occur_name
2047 PprUnfolding _ -> qualified_name pieces
2048 PprDebug -> qualified_name pieces
2049 PprShowAll -> ppBesides [qualified_name pieces,
2052 ppr other_sty (getIdUniType id),
2053 ppIdInfo other_sty id True (\x->x) nullIdEnv (getIdInfo id),
2054 ppPStr SLIT("-}") ])]
2056 occur_name = getOccurrenceName id _APPEND_
2057 ( _PK_ (if not (isSysLocalId id)
2059 else "." ++ (_UNPK_ (showUnique (getTheUnique id)))))
2061 qualified_name pieces
2062 = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
2064 pp_uniq (Id _ _ _ (PreludeId _)) = ppNil -- No uniq to add
2065 pp_uniq (Id _ _ _ (DataConId _ _ _ _ _ _)) = ppNil -- No uniq to add
2066 pp_uniq (Id _ _ _ (TupleConId _)) = ppNil -- No uniq to add
2067 pp_uniq (Id _ _ _ (LocalId _ _)) = ppNil -- uniq printed elsewhere
2068 pp_uniq (Id _ _ _ (SysLocalId _ _)) = ppNil -- ditto
2069 pp_uniq (Id _ _ _ (SpecPragmaId _ _ _)) = ppNil -- ditto
2070 pp_uniq (Id _ _ _ (InstId _)) = ppNil -- ditto
2071 pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getTheUnique other_id), ppPStr SLIT("-}")]
2073 -- For Robin Popplestone: print PprDebug Ids with # afterwards
2074 -- if they are of primitive type.
2075 pp_ubxd pretty = if isPrimType (getIdUniType id)
2076 then ppBeside pretty (ppChar '#')
2081 instance NamedThing Id where
2082 getExportFlag (Id _ _ _ details)
2085 get (DataConId _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
2086 get (TupleConId _) = NotExported
2087 get (ImportedId n) = getExportFlag n
2088 get (PreludeId n) = getExportFlag n
2089 get (TopLevId n) = getExportFlag n
2090 get (SuperDictSelId c _) = getExportFlag c
2091 get (ClassOpId c _) = getExportFlag c
2092 get (DefaultMethodId c _ _) = getExportFlag c
2093 get (DictFunId c ty from_here _) = instance_export_flag c ty from_here
2094 get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here
2095 get (SpecId unspec _ _) = getExportFlag unspec
2096 get (WorkerId unwrkr) = getExportFlag unwrkr
2097 get (InstId _) = NotExported
2098 get (LocalId _ _) = NotExported
2099 get (SysLocalId _ _) = NotExported
2100 get (SpecPragmaId _ _ _) = NotExported
2102 get (ProcessorCon _ _) = NotExported
2103 get (PodId _ _ i) = getExportFlag i
2104 #endif {- Data Parallel Haskell -}
2106 isLocallyDefined this_id@(Id _ _ _ details)
2109 get (DataConId _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
2110 get (TupleConId _) = False
2111 get (ImportedId _) = False
2112 get (PreludeId _) = False
2113 get (TopLevId n) = isLocallyDefined n
2114 get (SuperDictSelId c _) = isLocallyDefined c
2115 get (ClassOpId c _) = isLocallyDefined c
2116 get (DefaultMethodId c _ _) = isLocallyDefined c
2117 get (DictFunId c tyc from_here _) = from_here
2118 -- For DictFunId and ConstMethodId things, you really have to
2119 -- know whether it came from an imported instance or one
2120 -- really here; no matter where the tycon and class came from.
2122 get (ConstMethodId c tyc _ from_here _) = from_here
2123 get (SpecId unspec _ _) = isLocallyDefined unspec
2124 get (WorkerId unwrkr) = isLocallyDefined unwrkr
2125 get (InstId _) = True
2126 get (LocalId _ _) = True
2127 get (SysLocalId _ _) = True
2128 get (SpecPragmaId _ _ _) = True
2130 get (ProcessorCon _ _) = False
2131 get (PodId _ _ i) = isLocallyDefined i
2132 #endif {- Data Parallel Haskell -}
2134 getOrigName this_id@(Id u _ _ details)
2137 get (DataConId n _ _ _ _ _) = getOrigName n
2138 get (TupleConId a) = (pRELUDE_BUILTIN, SLIT("Tup") _APPEND_ _PK_ (show a))
2139 get (ImportedId n) = getOrigName n
2140 get (PreludeId n) = getOrigName n
2141 get (TopLevId n) = getOrigName n
2143 get (ClassOpId c op) = case (getOrigName c) of -- ToDo; better ???
2144 (mod, _) -> (mod, getClassOpString op)
2146 get (SpecId unspec ty_maybes _)
2147 = BIND getOrigName unspec _TO_ (mod, unspec_nm) ->
2148 BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
2151 (if not (toplevelishId unspec)
2157 get (WorkerId unwrkr)
2158 = BIND getOrigName unwrkr _TO_ (mod, unwrkr_nm) ->
2161 (if not (toplevelishId unwrkr)
2168 = (panic "NamedThing.Id.getOrigName (InstId)",
2169 BIND (getInstNamePieces True inst) _TO_ (piece1:pieces) ->
2170 BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
2171 _CONCAT_ (piece1 : dotted_pieces)
2174 get (LocalId n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
2176 get (SysLocalId n _) = (panic "NamedThing.Id.getOrigName (SysLocal)",
2178 get (SpecPragmaId n _ _)=(panic "NamedThing.Id.getOrigName (SpecPragmaId)",
2181 get (ProcessorCon a _) = ("PreludeBuiltin",
2182 "MkProcessor" ++ (show a))
2183 get (PodId d ity id)
2184 = BIND (getOrigName id) _TO_ (m,n) ->
2185 (m,n ++ ".mapped.POD"++ show d ++ "." ++ show ity)
2187 -- ToDo(hilly): should the above be using getIdNamePieces???
2188 #endif {- Data Parallel Haskell -}
2191 -- the remaining internally-generated flavours of
2192 -- Ids really do not have meaningful "original name" stuff,
2193 -- but we need to make up something (usually for debugging output)
2195 = BIND (getIdNamePieces True this_id) _TO_ (piece1:pieces) ->
2196 BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
2197 (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
2200 getOccurrenceName this_id@(Id _ _ _ details)
2203 get (DataConId n _ _ _ _ _) = getOccurrenceName n
2204 get (TupleConId a) = SLIT("Tup") _APPEND_ (_PK_ (show a))
2205 get (ImportedId n) = getOccurrenceName n
2206 get (PreludeId n) = getOccurrenceName n
2207 get (TopLevId n) = getOccurrenceName n
2208 get (ClassOpId _ op) = getClassOpString op
2210 get (ProcessorCon a _) = "MkProcessor" ++ (show a)
2211 get (PodId _ _ id) = getOccurrenceName id
2212 #endif {- Data Parallel Haskell -}
2213 get _ = snd (getOrigName this_id)
2215 getInformingModules id = panic "getInformingModule:Id"
2217 getSrcLoc (Id _ _ id_info details)
2220 get (DataConId n _ _ _ _ _) = getSrcLoc n
2221 get (TupleConId _) = mkBuiltinSrcLoc
2222 get (ImportedId n) = getSrcLoc n
2223 get (PreludeId n) = getSrcLoc n
2224 get (TopLevId n) = getSrcLoc n
2225 get (SuperDictSelId c _)= getSrcLoc c
2226 get (ClassOpId c _) = getSrcLoc c
2227 get (SpecId unspec _ _) = getSrcLoc unspec
2228 get (WorkerId unwrkr) = getSrcLoc unwrkr
2229 get (InstId i) = let (loc,_) = getInstOrigin i
2231 get (LocalId n _) = getSrcLoc n
2232 get (SysLocalId n _) = getSrcLoc n
2233 get (SpecPragmaId n _ _)= getSrcLoc n
2235 get (ProcessorCon _ _) = mkBuiltinSrcLoc
2236 get (PodId _ _ n) = getSrcLoc n
2237 #endif {- Data Parallel Haskell -}
2238 -- well, try the IdInfo
2239 get something_else = getSrcLocIdInfo id_info
2241 getTheUnique (Id u _ _ _) = u
2243 fromPreludeCore (Id _ _ _ details)
2246 get (DataConId _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
2247 get (TupleConId _) = True
2248 get (ImportedId n) = fromPreludeCore n
2249 get (PreludeId n) = fromPreludeCore n
2250 get (TopLevId n) = fromPreludeCore n
2251 get (SuperDictSelId c _) = fromPreludeCore c
2252 get (ClassOpId c _) = fromPreludeCore c
2253 get (DefaultMethodId c _ _) = fromPreludeCore c
2254 get (DictFunId c t _ _) = fromPreludeCore c && is_prelude_core_ty t
2255 get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t
2256 get (SpecId unspec _ _) = fromPreludeCore unspec
2257 get (WorkerId unwrkr) = fromPreludeCore unwrkr
2258 get (InstId _) = False
2259 get (LocalId _ _) = False
2260 get (SysLocalId _ _) = False
2261 get (SpecPragmaId _ _ _) = False
2263 get (ProcessorCon _ _) = True
2264 get (PodId _ _ id) = fromPreludeCore id
2265 #endif {- Data Parallel Haskell -}
2268 getType id = getIdUniType id
2271 Reason for @getTheUnique@: The code generator doesn't carry a
2272 @UniqueSupply@, so it wants to use the @Uniques@ out of local @Ids@