ghc/compiler/basicTypes/Id.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Id]{@Ids@: Value and constructor identifiers}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Id (
  10         -- TYPES
  11         GenId(..), -- *naughtily* used in some places (e.g., TcHsSyn)
  12         SYN_IE(Id), IdDetails,
  13         StrictnessMark(..),
  14         SYN_IE(ConTag), fIRST_TAG,
  15         SYN_IE(DataCon), SYN_IE(DictFun), SYN_IE(DictVar),
  16
  17         -- CONSTRUCTION
  18         mkConstMethodId,
  19         mkDataCon,
  20         mkDefaultMethodId,
  21         mkDictFunId,
  22         mkIdWithNewUniq,
  23         mkImported,
  24         mkInstId,
  25         mkMethodSelId,
  26         mkRecordSelId,
  27         mkSuperDictSelId,
  28         mkSysLocal,
  29         mkTemplateLocals,
  30         mkTupleCon,
  31         mkUserId,
  32         mkUserLocal,
  33         mkWorkerId,
  34
  35         -- MANGLING
  36         unsafeGenId2Id,
  37
  38         -- DESTRUCTION (excluding pragmatic info)
  39         idPrimRep,
  40         idType,
  41         idUnique,
  42
  43         dataConArgTys,
  44         dataConArity,
  45         dataConNumFields,
  46         dataConFieldLabels,
  47         dataConRawArgTys,
  48         dataConSig,
  49         dataConStrictMarks,
  50         dataConTag,
  51         dataConTyCon,
  52
  53         recordSelectorFieldLabel,
  54
  55         -- PREDICATES
  56         cmpEqDataCon,
  57         cmpId,
  58         cmpId_withSpecDataCon,
  59         externallyVisibleId,
  60         idHasNoFreeTyVars,
  61         idWantsToBeINLINEd,
  62         isBottomingId,
  63         isConstMethodId,
  64         isConstMethodId_maybe,
  65         isDataCon,
  66         isDefaultMethodId,
  67         isDefaultMethodId_maybe,
  68         isDictFunId,
  69         isImportedId,
  70         isMethodSelId,
  71         isNullaryDataCon,
  72         isSpecPragmaId,
  73         isSuperDictSelId_maybe,
  74         isSysLocalId,
  75         isTopLevId,
  76         isTupleCon,
  77         isWorkerId,
  78         isWrapperId,
  79         toplevelishId,
  80         unfoldingUnfriendlyId,
  81
  82         -- SUBSTITUTION
  83         applyTypeEnvToId,
  84         apply_to_Id,
  85
  86         -- PRINTING and RENUMBERING
  87         addId,
  88         nmbrDataCon,
  89         nmbrId,
  90         pprId,
  91         showId,
  92
  93         -- Specialialisation
  94         getIdSpecialisation,
  95         addIdSpecialisation,
  96
  97         -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
  98         addIdArity,
  99         addIdDemandInfo,
 100         addIdStrictness,
 101         addIdUpdateInfo,
 102         getIdArity,
 103         getIdDemandInfo,
 104         getIdInfo,
 105         getIdStrictness,
 106         getIdUnfolding,
 107         getIdUpdateInfo,
 108         getPragmaInfo,
 109         replaceIdInfo,
 110
 111         -- IdEnvs AND IdSets
 112         SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
 113         addOneToIdEnv,
 114         addOneToIdSet,
 115         combineIdEnvs,
 116         delManyFromIdEnv,
 117         delOneFromIdEnv,
 118         elementOfIdSet,
 119         emptyIdSet,
 120         growIdEnv,
 121         growIdEnvList,
 122         idSetToList,
 123         intersectIdSets,
 124         isEmptyIdSet,
 125         isNullIdEnv,
 126         lookupIdEnv,
 127         lookupNoFailIdEnv,
 128         mapIdEnv,
 129         minusIdSet,
 130         mkIdEnv,
 131         mkIdSet,
 132         modifyIdEnv,
 133         modifyIdEnv_Directly,
 134         nullIdEnv,
 135         rngIdEnv,
 136         unionIdSets,
 137         unionManyIdSets,
 138         unitIdEnv,
 139         unitIdSet
 140     ) where
 141
 142 IMP_Ubiq()
 143 IMPORT_DELOOPER(IdLoop)   -- for paranoia checking
 144 IMPORT_DELOOPER(TyLoop)   -- for paranoia checking
 145
 146 import Bag
 147 import Class            ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp )
 148 import IdInfo
 149 import Maybes           ( maybeToBool )
 150 import Name             ( appendRdr, nameUnique, mkLocalName, isLocalName,
 151                           isLocallyDefinedName,
 152                           mkTupleDataConName, mkCompoundName, mkCompoundName2,
 153                           isLexSym, isLexSpecialSym,
 154                           isLocallyDefined, changeUnique,
 155                           getOccName, origName, moduleOf,
 156                           isExported, ExportFlag(..),
 157                           RdrName(..), Name
 158                         )
 159 import FieldLabel       ( fieldLabelName, FieldLabel(..){-instances-} )
 160 import PragmaInfo       ( PragmaInfo(..) )
 161 import PprEnv           -- ( SYN_IE(NmbrM), NmbrEnv(..) )
 162 import PprType          ( getTypeString, typeMaybeString, specMaybeTysSuffix,
 163                           nmbrType, nmbrTyVar,
 164                           GenType, GenTyVar
 165                         )
 166 import PprStyle
 167 import Pretty
 168 import MatchEnv         ( MatchEnv )
 169 import SrcLoc           ( mkBuiltinSrcLoc )
 170 import TyCon            ( TyCon, mkTupleTyCon, tyConDataCons )
 171 import Type             ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
 172                           applyTyCon, instantiateTy,
 173                           tyVarsOfType, applyTypeEnvToTy, typePrimRep,
 174                           GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type)
 175                         )
 176 import TyVar            ( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) )
 177 import UniqFM
 178 import UniqSet          -- practically all of it
 179 import Unique           ( getBuiltinUniques, pprUnique, showUnique,
 180                           incrUnique,
 181                           Unique{-instance Ord3-}
 182                         )
 183 import Util             ( mapAccumL, nOfThem, zipEqual,
 184                           panic, panic#, pprPanic, assertPanic
 185                         )
 186 \end{code}
 187
 188 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
 189 follow.
 190
 191 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
 192 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
 193 strictness).  The essential info about different kinds of @Ids@ is
 194 in its @IdDetails@.
 195
 196 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
 197
 198 \begin{code}
 199 data GenId ty = Id
 200         Unique          -- Key for fast comparison
 201         Name
 202         ty              -- Id's type; used all the time;
 203         IdDetails       -- Stuff about individual kinds of Ids.
 204         PragmaInfo      -- Properties of this Id requested by programmer
 205                         -- eg specialise-me, inline-me
 206         IdInfo          -- Properties of this Id deduced by compiler
 207
 208 type Id = GenId Type
 209
 210 data StrictnessMark = MarkedStrict | NotMarkedStrict
 211
 212 data IdDetails
 213
 214   ---------------- Local values
 215
 216   = LocalId     Bool            -- Local name; mentioned by the user
 217                                 -- True <=> no free type vars
 218
 219   | SysLocalId  Bool            -- Local name; made up by the compiler
 220                                 -- as for LocalId
 221
 222   | SpecPragmaId                -- Local name; introduced by the compiler
 223                  (Maybe Id)     -- for explicit specid in pragma
 224                  Bool           -- as for LocalId
 225
 226   ---------------- Global values
 227
 228   | ImportedId                  -- Global name (Imported or Implicit); Id imported from an interface
 229
 230   | TopLevId                    -- Global name (LocalDef); Top-level in the orig source pgm
 231                                 -- (not moved there by transformations).
 232
 233         -- a TopLevId's type may contain free type variables, if
 234         -- the monomorphism restriction applies.
 235
 236   ---------------- Data constructors
 237
 238   | DataConId   ConTag
 239                 [StrictnessMark] -- Strict args; length = arity
 240                 [FieldLabel]    -- Field labels for this constructor
 241
 242                 [TyVar] [(Class,Type)] [Type] TyCon
 243                                 -- the type is:
 244                                 -- forall tyvars . theta_ty =>
 245                                 --    unitype_1 -> ... -> unitype_n -> tycon tyvars
 246
 247   | TupleConId  Int             -- Its arity
 248
 249   | RecordSelId FieldLabel
 250
 251   ---------------- Things to do with overloading
 252
 253   | SuperDictSelId              -- Selector for superclass dictionary
 254                 Class           -- The class (input dict)
 255                 Class           -- The superclass (result dict)
 256
 257   | MethodSelId Class           -- An overloaded class operation, with
 258                                 -- a fully polymorphic type.  Its code
 259                                 -- just selects a method from the
 260                                 -- dictionary.  The class.
 261                 ClassOp         -- The operation
 262
 263         -- NB: The IdInfo for a MethodSelId has all the info about its
 264         -- related "constant method Ids", which are just
 265         -- specialisations of this general one.
 266
 267   | DefaultMethodId             -- Default method for a particular class op
 268                 Class           -- same class, <blah-blah> info as MethodSelId
 269                 ClassOp         -- (surprise, surprise)
 270                 Bool            -- True <=> I *know* this default method Id
 271                                 -- is a generated one that just says
 272                                 -- `error "No default method for <op>"'.
 273
 274                                 -- see below
 275   | DictFunId   Class           -- A DictFun is uniquely identified
 276                 Type            -- by its class and type; this type has free type vars,
 277                                 -- whose identity is irrelevant.  Eg Class = Eq
 278                                 --                                   Type  = Tree a
 279                                 -- The "a" is irrelevant.  As it is too painful to
 280                                 -- actually do comparisons that way, we kindly supply
 281                                 -- a Unique for that purpose.
 282                 Module          -- module where instance came from
 283
 284                                 -- see below
 285   | ConstMethodId               -- A method which depends only on the type of the
 286                                 -- instance, and not on any further dictionaries etc.
 287                 Class           -- Uniquely identified by:
 288                 Type            -- (class, type, classop) triple
 289                 ClassOp
 290                 Module          -- module where instance came from
 291
 292   | InstId                      -- An instance of a dictionary, class operation,
 293                                 -- or overloaded value (Local name)
 294                 Bool            -- as for LocalId
 295
 296   | SpecId                      -- A specialisation of another Id
 297                 Id              -- Id of which this is a specialisation
 298                 [Maybe Type]    -- Types at which it is specialised;
 299                                 -- A "Nothing" says this type ain't relevant.
 300                 Bool            -- True <=> no free type vars; it's not enough
 301                                 -- to know about the unspec version, because
 302                                 -- we may specialise to a type w/ free tyvars
 303                                 -- (i.e., in one of the "Maybe Type" dudes).
 304
 305   | WorkerId                    -- A "worker" for some other Id
 306                 Id              -- Id for which this is a worker
 307
 308 type ConTag     = Int
 309 type DictVar    = Id
 310 type DictFun    = Id
 311 type DataCon    = Id
 312 \end{code}
 313
 314 DictFunIds are generated from instance decls.
 315 \begin{verbatim}
 316         class Foo a where
 317           op :: a -> a -> Bool
 318
 319         instance Foo a => Foo [a] where
 320           op = ...
 321 \end{verbatim}
 322 generates the dict fun id decl
 323 \begin{verbatim}
 324         dfun.Foo.[*] = \d -> ...
 325 \end{verbatim}
 326 The dfun id is uniquely named by the (class, type) pair.  Notice, it
 327 isn't a (class,tycon) pair any more, because we may get manually or
 328 automatically generated specialisations of the instance decl:
 329 \begin{verbatim}
 330         instance Foo [Int] where
 331           op = ...
 332 \end{verbatim}
 333 generates
 334 \begin{verbatim}
 335         dfun.Foo.[Int] = ...
 336 \end{verbatim}
 337 The type variables in the name are irrelevant; we print them as stars.
 338
 339
 340 Constant method ids are generated from instance decls where
 341 there is no context; that is, no dictionaries are needed to
 342 construct the method.  Example
 343 \begin{verbatim}
 344         instance Foo Int where
 345           op = ...
 346 \end{verbatim}
 347 Then we get a constant method
 348 \begin{verbatim}
 349         Foo.op.Int = ...
 350 \end{verbatim}
 351
 352 It is possible, albeit unusual, to have a constant method
 353 for an instance decl which has type vars:
 354 \begin{verbatim}
 355         instance Foo [a] where
 356           op []     ys = True
 357           op (x:xs) ys = False
 358 \end{verbatim}
 359 We get the constant method
 360 \begin{verbatim}
 361         Foo.op.[*] = ...
 362 \end{verbatim}
 363 So a constant method is identified by a class/op/type triple.
 364 The type variables in the type are irrelevant.
 365
 366
 367 For Ids whose names must be known/deducible in other modules, we have
 368 to conjure up their worker's names (and their worker's worker's
 369 names... etc) in a known systematic way.
 370
 371
 372 %************************************************************************
 373 %*                                                                      *
 374 \subsection[Id-documentation]{Documentation}
 375 %*                                                                      *
 376 %************************************************************************
 377
 378 [A BIT DATED [WDP]]
 379
 380 The @Id@ datatype describes {\em values}.  The basic things we want to
 381 know: (1)~a value's {\em type} (@idType@ is a very common
 382 operation in the compiler); and (2)~what ``flavour'' of value it might
 383 be---for example, it can be terribly useful to know that a value is a
 384 class method.
 385
 386 \begin{description}
 387 %----------------------------------------------------------------------
 388 \item[@DataConId@:] For the data constructors declared by a @data@
 389 declaration.  Their type is kept in {\em two} forms---as a regular
 390 @Type@ (in the usual place), and also in its constituent pieces (in
 391 the ``details''). We are frequently interested in those pieces.
 392
 393 %----------------------------------------------------------------------
 394 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
 395 the infinite family of tuples.
 396
 397 %----------------------------------------------------------------------
 398 \item[@ImportedId@:] These are values defined outside this module.
 399 {\em Everything} we want to know about them must be stored here (or in
 400 their @IdInfo@).
 401
 402 %----------------------------------------------------------------------
 403 \item[@TopLevId@:] These are values defined at the top-level in this
 404 module; i.e., those which {\em might} be exported (hence, a
 405 @Name@).  It does {\em not} include those which are moved to the
 406 top-level through program transformations.
 407
 408 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
 409 Theoretically, they could be floated inwards, but there's no known
 410 advantage in doing so.  This way, we can keep them with the same
 411 @Unique@ throughout (no cloning), and, in general, we don't have to be
 412 so paranoid about them.
 413
 414 In particular, we had the following problem generating an interface:
 415 We have to ``stitch together'' info (1)~from the typechecker-produced
 416 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
 417 what arities].  If the @Uniques@ on the @TopLevIds@ can {\em change}
 418 between (1) and (2), you're sunk!
 419
 420 %----------------------------------------------------------------------
 421 \item[@MethodSelId@:] A selector from a dictionary; it may select either
 422 a method or a dictionary for one of the class's superclasses.
 423
 424 %----------------------------------------------------------------------
 425 \item[@DictFunId@:]
 426
 427 @mkDictFunId [a,b..] theta C T@ is the function derived from the
 428 instance declaration
 429
 430         instance theta => C (T a b ..) where
 431                 ...
 432
 433 It builds function @Id@ which maps dictionaries for theta,
 434 to a dictionary for C (T a b ..).
 435
 436 *Note* that with the ``Mark Jones optimisation'', the theta may
 437 include dictionaries for the immediate superclasses of C at the type
 438 (T a b ..).
 439
 440 %----------------------------------------------------------------------
 441 \item[@InstId@:]
 442
 443 %----------------------------------------------------------------------
 444 \item[@SpecId@:]
 445
 446 %----------------------------------------------------------------------
 447 \item[@WorkerId@:]
 448
 449 %----------------------------------------------------------------------
 450 \item[@LocalId@:] A purely-local value, e.g., a function argument,
 451 something defined in a @where@ clauses, ... --- but which appears in
 452 the original program text.
 453
 454 %----------------------------------------------------------------------
 455 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
 456 the original program text; these are introduced by the compiler in
 457 doing its thing.
 458
 459 %----------------------------------------------------------------------
 460 \item[@SpecPragmaId@:] Introduced by the compiler to record
 461 Specialisation pragmas. It is dead code which MUST NOT be removed
 462 before specialisation.
 463 \end{description}
 464
 465 Further remarks:
 466 \begin{enumerate}
 467 %----------------------------------------------------------------------
 468 \item
 469
 470 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
 471 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
 472 properties:
 473 \begin{itemize}
 474 \item
 475 They have no free type variables, so if you are making a
 476 type-variable substitution you don't need to look inside them.
 477 \item
 478 They are constants, so they are not free variables.  (When the STG
 479 machine makes a closure, it puts all the free variables in the
 480 closure; the above are not required.)
 481 \end{itemize}
 482 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
 483 properties, but they may not.
 484 \end{enumerate}
 485
 486 %************************************************************************
 487 %*                                                                      *
 488 \subsection[Id-general-funs]{General @Id@-related functions}
 489 %*                                                                      *
 490 %************************************************************************
 491
 492 \begin{code}
 493 unsafeGenId2Id :: GenId ty -> Id
 494 unsafeGenId2Id (Id u n ty d p i) = Id u n (panic "unsafeGenId2Id:ty") d p i
 495
 496 isDataCon id = is_data (unsafeGenId2Id id)
 497  where
 498   is_data (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
 499   is_data (Id _ _ _ (TupleConId _) _ _)            = True
 500   is_data (Id _ _ _ (SpecId unspec _ _) _ _)       = is_data unspec
 501   is_data other                                    = False
 502
 503
 504 isTupleCon id = is_tuple (unsafeGenId2Id id)
 505  where
 506   is_tuple (Id _ _ _ (TupleConId _) _ _)         = True
 507   is_tuple (Id _ _ _ (SpecId unspec _ _) _ _)    = is_tuple unspec
 508   is_tuple other                                 = False
 509
 510 {-LATER:
 511 isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _)
 512   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 513     Just (unspec, ty_maybes)
 514 isSpecId_maybe other_id
 515   = Nothing
 516
 517 isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId specid _) _ _)
 518   = Just specid
 519 isSpecPragmaId_maybe other_id
 520   = Nothing
 521 -}
 522 \end{code}
 523
 524 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a nested
 525 @let(rec)@ (returns @False@), or whether it is {\em sure} to be
 526 defined at top level (returns @True@). This is used to decide whether
 527 the @Id@ is a candidate free variable. NB: you are only {\em sure}
 528 about something if it returns @True@!
 529
 530 \begin{code}
 531 toplevelishId     :: Id -> Bool
 532 idHasNoFreeTyVars :: Id -> Bool
 533
 534 toplevelishId (Id _ _ _ details _ _)
 535   = chk details
 536   where
 537     chk (DataConId _ _ _ _ _ _ _)   = True
 538     chk (TupleConId _)              = True
 539     chk (RecordSelId _)             = True
 540     chk ImportedId                  = True
 541     chk TopLevId                    = True      -- NB: see notes
 542     chk (SuperDictSelId _ _)        = True
 543     chk (MethodSelId _ _)           = True
 544     chk (DefaultMethodId _ _ _)     = True
 545     chk (DictFunId     _ _ _)       = True
 546     chk (ConstMethodId _ _ _ _)     = True
 547     chk (SpecId unspec _ _)         = toplevelishId unspec
 548                                     -- depends what the unspecialised thing is
 549     chk (WorkerId unwrkr)           = toplevelishId unwrkr
 550     chk (InstId       _)            = False     -- these are local
 551     chk (LocalId      _)            = False
 552     chk (SysLocalId   _)            = False
 553     chk (SpecPragmaId _ _)          = False
 554
 555 idHasNoFreeTyVars (Id _ _ _ details _ info)
 556   = chk details
 557   where
 558     chk (DataConId _ _ _ _ _ _ _) = True
 559     chk (TupleConId _)            = True
 560     chk (RecordSelId _)           = True
 561     chk ImportedId                = True
 562     chk TopLevId                  = True
 563     chk (SuperDictSelId _ _)      = True
 564     chk (MethodSelId _ _)         = True
 565     chk (DefaultMethodId _ _ _)   = True
 566     chk (DictFunId     _ _ _)     = True
 567     chk (ConstMethodId _ _ _ _)   = True
 568     chk (WorkerId unwrkr)         = idHasNoFreeTyVars unwrkr
 569     chk (SpecId _     _   no_free_tvs) = no_free_tvs
 570     chk (InstId         no_free_tvs) = no_free_tvs
 571     chk (LocalId        no_free_tvs) = no_free_tvs
 572     chk (SysLocalId     no_free_tvs) = no_free_tvs
 573     chk (SpecPragmaId _ no_free_tvs) = no_free_tvs
 574 \end{code}
 575
 576 \begin{code}
 577 isTopLevId (Id _ _ _ TopLevId _ _) = True
 578 isTopLevId other                   = False
 579
 580 isImportedId (Id _ _ _ ImportedId _ _) = True
 581 isImportedId other                     = False
 582
 583 isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
 584
 585 isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True
 586 isSysLocalId other                         = False
 587
 588 isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True
 589 isSpecPragmaId other                             = False
 590
 591 isMethodSelId (Id _ _ _ (MethodSelId _ _) _ _) = True
 592 isMethodSelId _                                = False
 593
 594 isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
 595 isDefaultMethodId other                                  = False
 596
 597 isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _)
 598   = Just (cls, clsop, err)
 599 isDefaultMethodId_maybe other = Nothing
 600
 601 isDictFunId (Id _ _ _ (DictFunId _ _ _) _ _) = True
 602 isDictFunId other                            = False
 603
 604 isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True
 605 isConstMethodId other                                  = False
 606
 607 isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _) _ _)
 608   = Just (cls, ty, clsop)
 609 isConstMethodId_maybe other = Nothing
 610
 611 isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
 612 isSuperDictSelId_maybe other_id                           = Nothing
 613
 614 isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
 615 isWorkerId other                     = False
 616
 617 isWrapperId id = workerExists (getIdStrictness id)
 618 \end{code}
 619
 620 \begin{code}
 621 {-LATER:
 622 pprIdInUnfolding :: IdSet -> Id -> Pretty
 623
 624 pprIdInUnfolding in_scopes v
 625   = let
 626         v_ty = idType v
 627     in
 628     -- local vars first:
 629     if v `elementOfUniqSet` in_scopes then
 630         pprUnique (idUnique v)
 631
 632     -- ubiquitous Ids with special syntax:
 633     else if v == nilDataCon then
 634         ppPStr SLIT("_NIL_")
 635     else if isTupleCon v then
 636         ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
 637
 638     -- ones to think about:
 639     else
 640         let
 641             (Id _ _ _ v_details _ _) = v
 642         in
 643         case v_details of
 644             -- these ones must have been exported by their original module
 645           ImportedId   -> pp_full_name
 646
 647             -- these ones' exportedness checked later...
 648           TopLevId  -> pp_full_name
 649           DataConId _ _ _ _ _ _ _ -> pp_full_name
 650
 651           RecordSelId lbl -> ppr sty lbl
 652
 653             -- class-ish things: class already recorded as "mentioned"
 654           SuperDictSelId c sc
 655             -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
 656           MethodSelId c o
 657             -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
 658           DefaultMethodId c o _
 659             -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
 660
 661             -- instance-ish things: should we try to figure out
 662             -- *exactly* which extra instances have to be exported? (ToDo)
 663           DictFunId  c t _
 664             -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
 665           ConstMethodId c t o _
 666             -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
 667
 668           -- specialisations and workers
 669           SpecId unspec ty_maybes _
 670             -> let
 671                   pp = pprIdInUnfolding in_scopes unspec
 672                in
 673                ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
 674                         ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
 675                         ppRbrack]
 676
 677           WorkerId unwrkr
 678             -> let
 679                   pp = pprIdInUnfolding in_scopes unwrkr
 680                in
 681                ppBeside (ppPStr SLIT("_WRKR_ ")) pp
 682
 683           -- anything else? we're nae interested
 684           other_id -> panic "pprIdInUnfolding:mystery Id"
 685   where
 686     ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
 687
 688     pp_full_name
 689       = let
 690             (OrigName m_str n_str) = origName "Id:ppr_Unfolding" v
 691
 692             pp_n =
 693               if isLexSym n_str && not (isLexSpecialSym n_str) then
 694                   ppBesides [ppLparen, ppPStr n_str, ppRparen]
 695               else
 696                   ppPStr n_str
 697         in
 698         if isPreludeDefined v then
 699             pp_n
 700         else
 701             ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
 702
 703     pp_class :: Class -> Pretty
 704     pp_class_op :: ClassOp -> Pretty
 705     pp_type :: Type -> Pretty
 706     pp_ty_maybe :: Maybe Type -> Pretty
 707
 708     pp_class    clas = ppr ppr_Unfolding clas
 709     pp_class_op op   = ppr ppr_Unfolding op
 710
 711     pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
 712
 713     pp_ty_maybe Nothing  = ppPStr SLIT("_N_")
 714     pp_ty_maybe (Just t) = pp_type t
 715 -}
 716 \end{code}
 717
 718 @whatsMentionedInId@ ferrets out the types/classes/instances on which
 719 this @Id@ depends.  If this Id is to appear in an interface, then
 720 those entities had Jolly Well be in scope.  Someone else up the
 721 call-tree decides that.
 722
 723 \begin{code}
 724 {-LATER:
 725 whatsMentionedInId
 726         :: IdSet                            -- Ids known to be in scope
 727         -> Id                               -- Id being processed
 728         -> (Bag Id, Bag TyCon, Bag Class)   -- mentioned Ids/TyCons/etc.
 729
 730 whatsMentionedInId in_scopes v
 731   = let
 732         v_ty = idType v
 733
 734         (tycons, clss)
 735           = getMentionedTyConsAndClassesFromType v_ty
 736
 737         result0 id_bag = (id_bag, tycons, clss)
 738
 739         result1 ids tcs cs
 740           = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
 741              tcs `unionBags` tycons,
 742              cs  `unionBags` clss)
 743     in
 744     -- local vars first:
 745     if v `elementOfUniqSet` in_scopes then
 746         result0 emptyBag    -- v not added to "mentioned"
 747
 748     -- ones to think about:
 749     else
 750         let
 751             (Id _ _ _ v_details _ _) = v
 752         in
 753         case v_details of
 754           -- specialisations and workers
 755           SpecId unspec ty_maybes _
 756             -> let
 757                   (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
 758                in
 759                result1 ids2 tcs2 cs2
 760
 761           WorkerId unwrkr
 762             -> let
 763                   (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
 764                in
 765                result1 ids2 tcs2 cs2
 766
 767           anything_else -> result0 (unitBag v) -- v is  added to "mentioned"
 768 -}
 769 \end{code}
 770
 771 Tell them who my wrapper function is.
 772 \begin{code}
 773 {-LATER:
 774 myWrapperMaybe :: Id -> Maybe Id
 775
 776 myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
 777 myWrapperMaybe other_id                           = Nothing
 778 -}
 779 \end{code}
 780
 781 \begin{code}
 782 unfoldingUnfriendlyId   -- return True iff it is definitely a bad
 783         :: Id           -- idea to export an unfolding that
 784         -> Bool         -- mentions this Id.  Reason: it cannot
 785                         -- possibly be seen in another module.
 786
 787 unfoldingUnfriendlyId id = not (externallyVisibleId id)
 788 \end{code}
 789
 790 @externallyVisibleId@: is it true that another module might be
 791 able to ``see'' this Id?
 792
 793 We need the @toplevelishId@ check as well as @isExported@ for when we
 794 compile instance declarations in the prelude.  @DictFunIds@ are
 795 ``exported'' if either their class or tycon is exported, but, in
 796 compiling the prelude, the compiler may not recognise that as true.
 797
 798 \begin{code}
 799 externallyVisibleId :: Id -> Bool
 800
 801 externallyVisibleId id@(Id _ _ _ details _ _)
 802   = if isLocallyDefined id then
 803         toplevelishId id && (isExported id || isDataCon id)
 804         -- NB: the use of "isExported" is most dodgy;
 805         -- We may eventually move to a situation where
 806         -- every Id is "externallyVisible", even if the
 807         -- module system's namespace control renders it
 808         -- "not exported".
 809     else
 810         True
 811         -- if visible here, it must be visible elsewhere, too.
 812 \end{code}
 813
 814 \begin{code}
 815 idWantsToBeINLINEd :: Id -> Bool
 816
 817 idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
 818 idWantsToBeINLINEd _                               = False
 819 \end{code}
 820
 821 For @unlocaliseId@: See the brief commentary in
 822 \tr{simplStg/SimplStg.lhs}.
 823
 824 \begin{code}
 825 {-LATER:
 826 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
 827
 828 unlocaliseId mod (Id u fn ty info TopLevId)
 829   = Just (Id u (unlocaliseFullName fn) ty info TopLevId)
 830
 831 unlocaliseId mod (Id u sn ty info (LocalId no_ftvs))
 832   = --false?: ASSERT(no_ftvs)
 833     let
 834         full_name = unlocaliseShortName mod u sn
 835     in
 836     Just (Id u full_name ty info TopLevId)
 837
 838 unlocaliseId mod (Id u sn ty info (SysLocalId no_ftvs))
 839   = --false?: on PreludeGlaST: ASSERT(no_ftvs)
 840     let
 841         full_name = unlocaliseShortName mod u sn
 842     in
 843     Just (Id u full_name ty info TopLevId)
 844
 845 unlocaliseId mod (Id u n ty info (SpecId unspec ty_maybes no_ftvs))
 846   = case unlocalise_parent mod u unspec of
 847       Nothing -> Nothing
 848       Just xx -> Just (Id u n ty info (SpecId xx ty_maybes no_ftvs))
 849
 850 unlocaliseId mod (Id u n ty info (WorkerId unwrkr))
 851   = case unlocalise_parent mod u unwrkr of
 852       Nothing -> Nothing
 853       Just xx -> Just (Id u n ty info (WorkerId xx))
 854
 855 unlocaliseId mod (Id u name ty info (InstId no_ftvs))
 856   = Just (Id u full_name ty info TopLevId)
 857         -- type might be wrong, but it hardly matters
 858         -- at this stage (just before printing C)  ToDo
 859   where
 860     name = nameOf (origName "Id.unlocaliseId" name)
 861     full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
 862
 863 unlocaliseId mod other_id = Nothing
 864
 865 --------------------
 866 -- we have to be Very Careful for workers/specs of
 867 -- local functions!
 868
 869 unlocalise_parent mod uniq (Id _ sn ty info (LocalId no_ftvs))
 870   = --false?: ASSERT(no_ftvs)
 871     let
 872         full_name = unlocaliseShortName mod uniq sn
 873     in
 874     Just (Id uniq full_name ty info TopLevId)
 875
 876 unlocalise_parent mod uniq (Id _ sn ty info (SysLocalId no_ftvs))
 877   = --false?: ASSERT(no_ftvs)
 878     let
 879         full_name = unlocaliseShortName mod uniq sn
 880     in
 881     Just (Id uniq full_name ty info TopLevId)
 882
 883 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
 884   -- we're OK otherwise
 885 -}
 886 \end{code}
 887
 888 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
 889 `Top-levelish Ids'' cannot have any free type variables, so applying
 890 the type-env cannot have any effect.  (NB: checked in CoreLint?)
 891
 892 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
 893 former ``should be'' the usual crunch point.
 894
 895 \begin{code}
 896 type TypeEnv = TyVarEnv Type
 897
 898 applyTypeEnvToId :: TypeEnv -> Id -> Id
 899
 900 applyTypeEnvToId type_env id@(Id _ _ ty _ _ _)
 901   | idHasNoFreeTyVars id
 902   = id
 903   | otherwise
 904   = apply_to_Id ( \ ty ->
 905         applyTypeEnvToTy type_env ty
 906     ) id
 907 \end{code}
 908
 909 \begin{code}
 910 apply_to_Id :: (Type -> Type) -> Id -> Id
 911
 912 apply_to_Id ty_fn (Id u n ty details prag info)
 913   = let
 914         new_ty = ty_fn ty
 915     in
 916     Id u n new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
 917   where
 918     apply_to_details (SpecId unspec ty_maybes no_ftvs)
 919       = let
 920             new_unspec = apply_to_Id ty_fn unspec
 921             new_maybes = map apply_to_maybe ty_maybes
 922         in
 923         SpecId new_unspec new_maybes (no_free_tvs ty)
 924         -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
 925       where
 926         apply_to_maybe Nothing   = Nothing
 927         apply_to_maybe (Just ty) = Just (ty_fn ty)
 928
 929     apply_to_details (WorkerId unwrkr)
 930       = let
 931             new_unwrkr = apply_to_Id ty_fn unwrkr
 932         in
 933         WorkerId new_unwrkr
 934
 935     apply_to_details other = other
 936 \end{code}
 937
 938 Sadly, I don't think the one using the magic typechecker substitution
 939 can be done with @apply_to_Id@.  Here we go....
 940
 941 Strictness is very important here.  We can't leave behind thunks
 942 with pointers to the substitution: it {\em must} be single-threaded.
 943
 944 \begin{code}
 945 {-LATER:
 946 applySubstToId :: Subst -> Id -> (Subst, Id)
 947
 948 applySubstToId subst id@(Id u n ty info details)
 949   -- *cannot* have a "idHasNoFreeTyVars" get-out clause
 950   -- because, in the typechecker, we are still
 951   -- *concocting* the types.
 952   = case (applySubstToTy     subst ty)          of { (s2, new_ty)      ->
 953     case (applySubstToIdInfo s2    info)        of { (s3, new_info)    ->
 954     case (apply_to_details   s3 new_ty details) of { (s4, new_details) ->
 955     (s4, Id u n new_ty new_info new_details) }}}
 956   where
 957     apply_to_details subst _ (InstId inst no_ftvs)
 958       = case (applySubstToInst subst inst) of { (s2, new_inst) ->
 959         (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
 960
 961     apply_to_details subst new_ty (SpecId unspec ty_maybes _)
 962       = case (applySubstToId subst unspec)           of { (s2, new_unspec) ->
 963         case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
 964         (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
 965         -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
 966       where
 967         apply_to_maybe subst Nothing   = (subst, Nothing)
 968         apply_to_maybe subst (Just ty)
 969           = case (applySubstToTy subst ty) of { (s2, new_ty) ->
 970             (s2, Just new_ty) }
 971
 972     apply_to_details subst _ (WorkerId unwrkr)
 973       = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
 974         (s2, WorkerId new_unwrkr) }
 975
 976     apply_to_details subst _ other = (subst, other)
 977 -}
 978 \end{code}
 979
 980 %************************************************************************
 981 %*                                                                      *
 982 \subsection[Id-type-funs]{Type-related @Id@ functions}
 983 %*                                                                      *
 984 %************************************************************************
 985
 986 \begin{code}
 987 idType :: GenId ty -> ty
 988
 989 idType (Id _ _ ty _ _ _) = ty
 990 \end{code}
 991
 992 \begin{code}
 993 {-LATER:
 994 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
 995
 996 getMentionedTyConsAndClassesFromId id
 997  = getMentionedTyConsAndClassesFromType (idType id)
 998 -}
 999 \end{code}
1000
1001 \begin{code}
1002 idPrimRep i = typePrimRep (idType i)
1003 \end{code}
1004
1005 \begin{code}
1006 {-LATER:
1007 getInstIdModule (Id _ _ _ (DictFunId _ _ mod)) = mod
1008 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ mod)) = mod
1009 getInstIdModule other = panic "Id:getInstIdModule"
1010 -}
1011 \end{code}
1012
1013 %************************************************************************
1014 %*                                                                      *
1015 \subsection[Id-overloading]{Functions related to overloading}
1016 %*                                                                      *
1017 %************************************************************************
1018
1019 \begin{code}
1020 mkSuperDictSelId u c sc ty info
1021   = mk_classy_id (SuperDictSelId c sc) SLIT("sdsel") (Left (origName "mkSuperDictSelId" sc)) u c ty info
1022
1023 mkMethodSelId u rec_c op ty info
1024   = mk_classy_id (MethodSelId rec_c op) SLIT("meth") (Right (classOpString op)) u rec_c ty info
1025
1026 mkDefaultMethodId u rec_c op gen ty info
1027   = mk_classy_id (DefaultMethodId rec_c op gen) SLIT("defm") (Right (classOpString op)) u rec_c ty info
1028
1029 mk_classy_id details str op_str u rec_c ty info
1030   = Id u n ty details NoPragmaInfo info
1031   where
1032     cname = getName rec_c -- we get other info out of here
1033     cname_orig = origName "mk_classy_id" cname
1034     cmod = moduleOf cname_orig
1035
1036     n = mkCompoundName u cmod str [Left cname_orig, op_str] cname
1037
1038 mkDictFunId u c ity full_ty from_here locn mod info
1039   = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info
1040   where
1041     n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : renum_type_string full_ty ity) from_here locn
1042
1043 mkConstMethodId u c op ity full_ty from_here locn mod info
1044   = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info
1045   where
1046     n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : renum_type_string full_ty ity) from_here locn
1047
1048 renum_type_string full_ty ity
1049   = initNmbr (
1050         nmbrType full_ty    `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering...
1051         nmbrType ity        `thenNmbr` \ rn_ity ->
1052         returnNmbr (getTypeString rn_ity)
1053     )
1054
1055 mkWorkerId u unwrkr ty info
1056   = Id u n ty (WorkerId unwrkr) NoPragmaInfo info
1057   where
1058     unwrkr_name = getName unwrkr
1059     unwrkr_orig = origName "mkWorkerId" unwrkr_name
1060     umod = moduleOf unwrkr_orig
1061
1062     n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name
1063
1064 mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
1065
1066 {-LATER:
1067 getConstMethodId clas op ty
1068   = -- constant-method info is hidden in the IdInfo of
1069     -- the class-op id (as mentioned up above).
1070     let
1071         sel_id = getMethodSelId clas op
1072     in
1073     case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1074       Just xx -> xx
1075       Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
1076         ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1077                ppr PprDebug sel_id],
1078         ppStr "(This can arise if an interface pragma refers to an instance",
1079         ppStr "but there is no imported interface which *defines* that instance.",
1080         ppStr "The info above, however ugly, should indicate what else you need to import."
1081         ])
1082 -}
1083 \end{code}
1084
1085 %************************************************************************
1086 %*                                                                      *
1087 \subsection[local-funs]{@LocalId@-related functions}
1088 %*                                                                      *
1089 %************************************************************************
1090
1091 \begin{code}
1092 mkImported  n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
1093
1094 {-LATER:
1095 updateIdType :: Id -> Type -> Id
1096 updateIdType (Id u n _ info details) ty = Id u n ty info details
1097 -}
1098 \end{code}
1099
1100 \begin{code}
1101 type MyTy a b = GenType (GenTyVar a) b
1102 type MyId a b = GenId (MyTy a b)
1103
1104 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1105
1106 -- SysLocal: for an Id being created by the compiler out of thin air...
1107 -- UserLocal: an Id with a name the user might recognize...
1108 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1109
1110 mkSysLocal str uniq ty loc
1111   = Id uniq (mkLocalName uniq str True{-emph uniq-} loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
1112
1113 mkUserLocal str uniq ty loc
1114   = Id uniq (mkLocalName uniq str False{-emph name-} loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
1115
1116 -- mkUserId builds a local or top-level Id, depending on the name given
1117 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1118 mkUserId name ty pragma_info
1119   | isLocalName name
1120   = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo
1121   | otherwise
1122   = Id (nameUnique name) name ty
1123         (if isLocallyDefinedName name then TopLevId else ImportedId)
1124         pragma_info noIdInfo
1125 \end{code}
1126
1127
1128 \begin{code}
1129 {-LATER:
1130
1131 -- for a SpecPragmaId being created by the compiler out of thin air...
1132 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1133 mkSpecPragmaId str uniq ty specid loc
1134   = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty))
1135
1136 -- for new SpecId
1137 mkSpecId u unspec ty_maybes ty info
1138   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1139     Id u n ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1140
1141 -- Specialised version of constructor: only used in STG and code generation
1142 -- Note: The specialsied Id has the same unique as the unspeced Id
1143
1144 mkSameSpecCon ty_maybes unspec@(Id u n ty info details)
1145   = ASSERT(isDataCon unspec)
1146     ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1147     Id u n new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1148   where
1149     new_ty = specialiseTy ty ty_maybes 0
1150
1151 localiseId :: Id -> Id
1152 localiseId id@(Id u n ty info details)
1153   = Id u (mkShortName name loc) ty info (LocalId (no_free_tvs ty))
1154   where
1155     name = getOccName id
1156     loc  = getSrcLoc id
1157 -}
1158
1159 mkIdWithNewUniq :: Id -> Unique -> Id
1160
1161 mkIdWithNewUniq (Id _ n ty details prag info) u
1162   = Id u (changeUnique n u) ty details prag info
1163 \end{code}
1164
1165 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
1166 @Uniques@, but that's OK because the templates are supposed to be
1167 instantiated before use.
1168 \begin{code}
1169 mkTemplateLocals :: [Type] -> [Id]
1170 mkTemplateLocals tys
1171   = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1172             (getBuiltinUniques (length tys))
1173             tys
1174 \end{code}
1175
1176 \begin{code}
1177 getIdInfo     :: GenId ty -> IdInfo
1178 getPragmaInfo :: GenId ty -> PragmaInfo
1179
1180 getIdInfo     (Id _ _ _ _ _ info) = info
1181 getPragmaInfo (Id _ _ _ _ info _) = info
1182
1183 replaceIdInfo :: Id -> IdInfo -> Id
1184
1185 replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
1186
1187 {-LATER:
1188 selectIdInfoForSpecId :: Id -> IdInfo
1189 selectIdInfoForSpecId unspec
1190   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1191     noIdInfo `addInfo_UF` getIdUnfolding unspec
1192 -}
1193 \end{code}
1194
1195 %************************************************************************
1196 %*                                                                      *
1197 \subsection[Id-arities]{Arity-related functions}
1198 %*                                                                      *
1199 %************************************************************************
1200
1201 For locally-defined Ids, the code generator maintains its own notion
1202 of their arities; so it should not be asking...  (but other things
1203 besides the code-generator need arity info!)
1204
1205 \begin{code}
1206 getIdArity :: Id -> ArityInfo
1207 getIdArity id@(Id _ _ _ _ _ id_info)
1208   = --ASSERT( not (isDataCon id))
1209     getInfo id_info
1210
1211 dataConArity, dataConNumFields :: DataCon -> Int
1212
1213 dataConArity id@(Id _ _ _ _ _ id_info)
1214   = ASSERT(isDataCon id)
1215     case (arityMaybe (getInfo id_info)) of
1216       Just  i -> i
1217       Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1218
1219 dataConNumFields id
1220   = ASSERT(isDataCon id)
1221     case (dataConSig id) of { (_, _, arg_tys, _) ->
1222     length arg_tys }
1223
1224 isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
1225
1226 addIdArity :: Id -> Int -> Id
1227 addIdArity (Id u n ty details pinfo info) arity
1228   = Id u n ty details pinfo (info `addInfo` (mkArityInfo arity))
1229 \end{code}
1230
1231 %************************************************************************
1232 %*                                                                      *
1233 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1234 %*                                                                      *
1235 %************************************************************************
1236
1237 \begin{code}
1238 mkDataCon :: Name
1239           -> [StrictnessMark] -> [FieldLabel]
1240           -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1241 --ToDo:   -> SpecEnv
1242           -> Id
1243   -- can get the tag and all the pieces of the type from the Type
1244
1245 mkDataCon n stricts fields tvs ctxt args_tys tycon
1246   = ASSERT(length stricts == length args_tys)
1247     data_con
1248   where
1249     -- NB: data_con self-recursion; should be OK as tags are not
1250     -- looked at until late in the game.
1251     data_con
1252       = Id (nameUnique n)
1253            n
1254            type_of_constructor
1255            (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
1256            IWantToBeINLINEd     -- Always inline constructors if possible
1257            datacon_info
1258
1259     data_con_tag    = position_within fIRST_TAG data_con_family
1260
1261     data_con_family = tyConDataCons tycon
1262
1263     position_within :: Int -> [Id] -> Int
1264
1265     position_within acc (c:cs)
1266       = if c == data_con then acc else position_within (acc+1) cs
1267 #ifdef DEBUG
1268     position_within acc []
1269       = panic "mkDataCon: con not found in family"
1270 #endif
1271
1272     type_of_constructor
1273       = mkSigmaTy tvs ctxt
1274         (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1275
1276     datacon_info = noIdInfo `addInfo_UF` unfolding
1277                             `addInfo` mkArityInfo arity
1278 --ToDo:                     `addInfo` specenv
1279
1280     arity = length ctxt + length args_tys
1281
1282     unfolding
1283       = noInfo_UF
1284 {- LATER:
1285       = -- if arity == 0
1286         -- then noIdInfo
1287         -- else -- do some business...
1288         let
1289             (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1290             tyvar_tys = mkTyVarTys tyvars
1291         in
1292         case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
1293
1294         mkUnfolding EssentialUnfolding -- for data constructors
1295                     (mkLam tyvars (dict_vars ++ vars) plain_Con)
1296         }
1297
1298     mk_uf_bits tvs ctxt arg_tys tycon
1299       = let
1300             (inst_env, tyvars, tyvar_tys)
1301               = instantiateTyVarTemplates tvs
1302                                           (map uniqueOf tvs)
1303         in
1304             -- the "context" and "arg_tys" have TyVarTemplates in them, so
1305             -- we instantiate those types to have the right TyVars in them
1306             -- instead.
1307         case (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1308                                                         of { inst_dict_tys ->
1309         case (map (instantiateTauTy inst_env) arg_tys)  of { inst_arg_tys ->
1310
1311             -- We can only have **ONE** call to mkTemplateLocals here;
1312             -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1313             -- (Mega-Sigh) [ToDo]
1314         case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars ->
1315
1316         case (splitAt (length ctxt) all_vars)   of { (dict_vars, vars) ->
1317
1318         (tyvars, dict_vars, vars)
1319         }}}}
1320       where
1321         -- these are really dubious Types, but they are only to make the
1322         -- binders for the lambdas for tossed-away dicts.
1323         ctxt_ty (clas, ty) = mkDictTy clas ty
1324 -}
1325 \end{code}
1326
1327 \begin{code}
1328 mkTupleCon :: Arity -> Id
1329
1330 mkTupleCon arity
1331   = Id unique n ty (TupleConId arity) NoPragmaInfo tuplecon_info
1332   where
1333     n           = mkTupleDataConName arity
1334     unique      = uniqueOf n
1335     ty          = mkSigmaTy tyvars []
1336                    (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1337     tycon       = mkTupleTyCon arity
1338     tyvars      = take arity alphaTyVars
1339     tyvar_tys   = mkTyVarTys tyvars
1340
1341     tuplecon_info
1342       = noIdInfo `addInfo_UF` unfolding
1343                  `addInfo` mkArityInfo arity
1344 --LATER:?        `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1345
1346     unfolding
1347       = noInfo_UF
1348 {- LATER:
1349       = -- if arity == 0
1350         -- then noIdInfo
1351         -- else -- do some business...
1352         let
1353             (tyvars, dict_vars, vars) = mk_uf_bits arity
1354             tyvar_tys = mkTyVarTys tyvars
1355         in
1356         case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
1357         mkUnfolding
1358             EssentialUnfolding    -- data constructors
1359             (mkLam tyvars (dict_vars ++ vars) plain_Con) }
1360
1361     mk_uf_bits arity
1362       = case (mkTemplateLocals tyvar_tys) of { vars ->
1363         (tyvars, [], vars) }
1364       where
1365         tyvar_tmpls     = take arity alphaTyVars
1366         (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
1367 -}
1368
1369 fIRST_TAG :: ConTag
1370 fIRST_TAG =  1  -- Tags allocated from here for real constructors
1371 \end{code}
1372
1373 \begin{code}
1374 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1375 dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _) _ _) = tag
1376 dataConTag (Id _ _ _ (TupleConId _) _ _)              = fIRST_TAG
1377 dataConTag (Id _ _ _ (SpecId unspec _ _) _ _)         = dataConTag unspec
1378
1379 dataConTyCon :: DataCon -> TyCon        -- will panic if not a DataCon
1380 dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
1381 dataConTyCon (Id _ _ _ (TupleConId a) _ _)                = mkTupleTyCon a
1382
1383 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1384                                         -- will panic if not a DataCon
1385
1386 dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1387   = (tyvars, theta_ty, arg_tys, tycon)
1388
1389 dataConSig (Id _ _ _ (TupleConId arity) _ _)
1390   = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1391   where
1392     tyvars      = take arity alphaTyVars
1393     tyvar_tys   = mkTyVarTys tyvars
1394
1395 dataConFieldLabels :: DataCon -> [FieldLabel]
1396 dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields
1397 dataConFieldLabels (Id _ _ _ (TupleConId _)                 _ _) = []
1398
1399 dataConStrictMarks :: DataCon -> [StrictnessMark]
1400 dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts
1401 dataConStrictMarks (Id _ _ _ (TupleConId arity)              _ _)
1402   = nOfThem arity NotMarkedStrict
1403
1404 dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
1405 dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys }
1406
1407 dataConArgTys :: DataCon
1408               -> [Type]         -- Instantiated at these types
1409               -> [Type]         -- Needs arguments of these types
1410 dataConArgTys con_id inst_tys
1411  = map (instantiateTy tenv) arg_tys
1412  where
1413     (tyvars, _, arg_tys, _) = dataConSig con_id
1414     tenv                    = zipEqual "dataConArgTys" tyvars inst_tys
1415 \end{code}
1416
1417 \begin{code}
1418 mkRecordSelId field_label selector_ty
1419   = Id (nameUnique name)
1420        name
1421        selector_ty
1422        (RecordSelId field_label)
1423        NoPragmaInfo
1424        noIdInfo
1425   where
1426     name = fieldLabelName field_label
1427
1428 recordSelectorFieldLabel :: Id -> FieldLabel
1429 recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl
1430 \end{code}
1431
1432
1433 Data type declarations are of the form:
1434 \begin{verbatim}
1435 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1436 \end{verbatim}
1437 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1438 @C1 x y z@, we want a function binding:
1439 \begin{verbatim}
1440 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1441 \end{verbatim}
1442 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1443 2nd-order polymorphic lambda calculus with explicit types.
1444
1445 %************************************************************************
1446 %*                                                                      *
1447 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1448 %*                                                                      *
1449 %************************************************************************
1450
1451 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1452 and generates an @Unfolding@.  The @Ids@ and @TyVars@ don't really
1453 have to be new, because we are only producing a template.
1454
1455 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1456 --WDP)?
1457
1458 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1459 EXPORTED.  It just returns the binders (@TyVars@ and @Ids@) [in the
1460 example above: a, b, and x, y, z], which is enough (in the important
1461 \tr{DsExpr} case).  (The middle set of @Ids@ is binders for any
1462 dictionaries, in the even of an overloaded data-constructor---none at
1463 present.)
1464
1465 \begin{code}
1466 getIdUnfolding :: Id -> Unfolding
1467
1468 getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
1469
1470 {-LATER:
1471 addIdUnfolding :: Id -> Unfolding -> Id
1472 addIdUnfolding id@(Id u n ty info details) unfold_details
1473   = ASSERT(
1474         case (isLocallyDefined id, unfold_details) of
1475         (_,     NoUnfolding) -> True
1476         (True,  IWantToBeINLINEd _) -> True
1477         (False, IWantToBeINLINEd _) -> False -- v bad
1478         (False, _)                  -> True
1479         _                           -> False -- v bad
1480     )
1481     Id u n ty (info `addInfo_UF` unfold_details) details
1482 -}
1483 \end{code}
1484
1485 In generating selector functions (take a dictionary, give back one
1486 component...), we need to what out for the nothing-to-select cases (in
1487 which case the ``selector'' is just an identity function):
1488 \begin{verbatim}
1489 class Eq a => Foo a { }     # the superdict selector for "Eq"
1490
1491 class Foo a { op :: Complex b => c -> b -> a }
1492                             # the method selector for "op";
1493                             # note local polymorphism...
1494 \end{verbatim}
1495
1496 %************************************************************************
1497 %*                                                                      *
1498 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1499 %*                                                                      *
1500 %************************************************************************
1501
1502 \begin{code}
1503 getIdDemandInfo :: Id -> DemandInfo
1504 getIdDemandInfo (Id _ _ _ _ _ info) = getInfo info
1505
1506 addIdDemandInfo :: Id -> DemandInfo -> Id
1507 addIdDemandInfo (Id u n ty details prags info) demand_info
1508   = Id u n ty details prags (info `addInfo` demand_info)
1509 \end{code}
1510
1511 \begin{code}
1512 getIdUpdateInfo :: Id -> UpdateInfo
1513 getIdUpdateInfo (Id _ _ _ _ _ info) = getInfo info
1514
1515 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1516 addIdUpdateInfo (Id u n ty details prags info) upd_info
1517   = Id u n ty details prags (info `addInfo` upd_info)
1518 \end{code}
1519
1520 \begin{code}
1521 {- LATER:
1522 getIdArgUsageInfo :: Id -> ArgUsageInfo
1523 getIdArgUsageInfo (Id u n ty info details) = getInfo info
1524
1525 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1526 addIdArgUsageInfo (Id u n ty info details) au_info
1527   = Id u n ty (info `addInfo` au_info) details
1528 -}
1529 \end{code}
1530
1531 \begin{code}
1532 {- LATER:
1533 getIdFBTypeInfo :: Id -> FBTypeInfo
1534 getIdFBTypeInfo (Id u n ty info details) = getInfo info
1535
1536 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1537 addIdFBTypeInfo (Id u n ty info details) upd_info
1538   = Id u n ty (info `addInfo` upd_info) details
1539 -}
1540 \end{code}
1541
1542 \begin{code}
1543 getIdSpecialisation :: Id -> SpecEnv
1544 getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
1545
1546 addIdSpecialisation :: Id -> SpecEnv -> Id
1547 addIdSpecialisation (Id u n ty details prags info) spec_info
1548   = Id u n ty details prags (info `addInfo` spec_info)
1549 \end{code}
1550
1551 Strictness: we snaffle the info out of the IdInfo.
1552
1553 \begin{code}
1554 getIdStrictness :: Id -> StrictnessInfo
1555
1556 getIdStrictness (Id _ _ _ _ _ info) = getInfo info
1557
1558 addIdStrictness :: Id -> StrictnessInfo -> Id
1559
1560 addIdStrictness (Id u n ty details prags info) strict_info
1561   = Id u n ty details prags (info `addInfo` strict_info)
1562 \end{code}
1563
1564 %************************************************************************
1565 %*                                                                      *
1566 \subsection[Id-comparison]{Comparison functions for @Id@s}
1567 %*                                                                      *
1568 %************************************************************************
1569
1570 Comparison: equality and ordering---this stuff gets {\em hammered}.
1571
1572 \begin{code}
1573 cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = cmp u1 u2
1574 -- short and very sweet
1575 \end{code}
1576
1577 \begin{code}
1578 instance Ord3 (GenId ty) where
1579     cmp = cmpId
1580
1581 instance Eq (GenId ty) where
1582     a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
1583     a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True  }
1584
1585 instance Ord (GenId ty) where
1586     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
1587     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
1588     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
1589     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
1590     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1591 \end{code}
1592
1593 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1594 account when comparing two data constructors. We need to do this
1595 because a specialised data constructor has the same Unique as its
1596 unspecialised counterpart.
1597
1598 \begin{code}
1599 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1600
1601 cmpId_withSpecDataCon id1 id2
1602   | eq_ids && isDataCon id1 && isDataCon id2
1603   = cmpEqDataCon id1 id2
1604
1605   | otherwise
1606   = cmp_ids
1607   where
1608     cmp_ids = cmpId id1 id2
1609     eq_ids  = case cmp_ids of { EQ_ -> True; other -> False }
1610
1611 cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _)
1612   = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1613
1614 cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_
1615 cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_
1616 cmpEqDataCon _                             _ = EQ_
1617 \end{code}
1618
1619 %************************************************************************
1620 %*                                                                      *
1621 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1622 %*                                                                      *
1623 %************************************************************************
1624
1625 \begin{code}
1626 instance Outputable ty => Outputable (GenId ty) where
1627     ppr sty id = pprId sty id
1628
1629 -- and a SPECIALIZEd one:
1630 instance Outputable {-Id, i.e.:-}(GenId Type) where
1631     ppr sty id = pprId sty id
1632
1633 showId :: PprStyle -> Id -> String
1634 showId sty id = ppShow 80 (pprId sty id)
1635 \end{code}
1636
1637 Default printing code (not used for interfaces):
1638 \begin{code}
1639 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1640
1641 pprId sty (Id u n _ _ _ _) = ppr sty n
1642   -- WDP 96/05/06: We can re-elaborate this as we go along...
1643 \end{code}
1644
1645 \begin{code}
1646 idUnique (Id u _ _ _ _ _) = u
1647
1648 instance Uniquable (GenId ty) where
1649     uniqueOf = idUnique
1650
1651 instance NamedThing (GenId ty) where
1652     getName this_id@(Id u n _ details _ _) = n
1653 \end{code}
1654
1655 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1656 the @Uniques@ out of local @Ids@ given to it.
1657
1658 %************************************************************************
1659 %*                                                                      *
1660 \subsection{@IdEnv@s and @IdSet@s}
1661 %*                                                                      *
1662 %************************************************************************
1663
1664 \begin{code}
1665 type IdEnv elt = UniqFM elt
1666
1667 nullIdEnv         :: IdEnv a
1668
1669 mkIdEnv           :: [(GenId ty, a)] -> IdEnv a
1670 unitIdEnv         :: GenId ty -> a -> IdEnv a
1671 addOneToIdEnv     :: IdEnv a -> GenId ty -> a -> IdEnv a
1672 growIdEnv         :: IdEnv a -> IdEnv a -> IdEnv a
1673 growIdEnvList     :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1674
1675 delManyFromIdEnv  :: IdEnv a -> [GenId ty] -> IdEnv a
1676 delOneFromIdEnv   :: IdEnv a -> GenId ty -> IdEnv a
1677 combineIdEnvs     :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1678 mapIdEnv          :: (a -> b) -> IdEnv a -> IdEnv b
1679 modifyIdEnv       :: (a -> a) -> IdEnv a -> GenId ty -> IdEnv a
1680 rngIdEnv          :: IdEnv a -> [a]
1681
1682 isNullIdEnv       :: IdEnv a -> Bool
1683 lookupIdEnv       :: IdEnv a -> GenId ty -> Maybe a
1684 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1685 \end{code}
1686
1687 \begin{code}
1688 addOneToIdEnv    = addToUFM
1689 combineIdEnvs    = plusUFM_C
1690 delManyFromIdEnv = delListFromUFM
1691 delOneFromIdEnv  = delFromUFM
1692 growIdEnv        = plusUFM
1693 lookupIdEnv      = lookupUFM
1694 mapIdEnv         = mapUFM
1695 mkIdEnv          = listToUFM
1696 nullIdEnv        = emptyUFM
1697 rngIdEnv         = eltsUFM
1698 unitIdEnv        = unitUFM
1699
1700 growIdEnvList     env pairs = plusUFM env (listToUFM pairs)
1701 isNullIdEnv       env       = sizeUFM env == 0
1702 lookupNoFailIdEnv env id    = case (lookupIdEnv env id) of { Just xx -> xx }
1703
1704 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1705 -- modify function, and put it back.
1706
1707 modifyIdEnv mangle_fn env key
1708   = case (lookupIdEnv env key) of
1709       Nothing -> env
1710       Just xx -> addOneToIdEnv env key (mangle_fn xx)
1711
1712 modifyIdEnv_Directly mangle_fn env key
1713   = case (lookupUFM_Directly env key) of
1714       Nothing -> env
1715       Just xx -> addToUFM_Directly env key (mangle_fn xx)
1716 \end{code}
1717
1718 \begin{code}
1719 type GenIdSet ty = UniqSet (GenId ty)
1720 type IdSet       = UniqSet (GenId Type)
1721
1722 emptyIdSet      :: GenIdSet ty
1723 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1724 unionIdSets     :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1725 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1726 idSetToList     :: GenIdSet ty -> [GenId ty]
1727 unitIdSet       :: GenId ty -> GenIdSet ty
1728 addOneToIdSet   :: GenIdSet ty -> GenId ty -> GenIdSet ty
1729 elementOfIdSet  :: GenId ty -> GenIdSet ty -> Bool
1730 minusIdSet      :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1731 isEmptyIdSet    :: GenIdSet ty -> Bool
1732 mkIdSet         :: [GenId ty] -> GenIdSet ty
1733
1734 emptyIdSet      = emptyUniqSet
1735 unitIdSet       = unitUniqSet
1736 addOneToIdSet   = addOneToUniqSet
1737 intersectIdSets = intersectUniqSets
1738 unionIdSets     = unionUniqSets
1739 unionManyIdSets = unionManyUniqSets
1740 idSetToList     = uniqSetToList
1741 elementOfIdSet  = elementOfUniqSet
1742 minusIdSet      = minusUniqSet
1743 isEmptyIdSet    = isEmptyUniqSet
1744 mkIdSet         = mkUniqSet
1745 \end{code}
1746
1747 \begin{code}
1748 addId, nmbrId, nmbrDataCon :: Id -> NmbrM Id
1749
1750 addId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1751   = case (lookupUFM_Directly idenv u) of
1752       Just xx -> trace "addId: already in map!" $
1753                  (nenv, xx)
1754       Nothing ->
1755         if toplevelishId id then
1756             trace "addId: can't add toplevelish!" $
1757             (nenv, id)
1758         else -- alloc a new unique for this guy
1759              -- and add an entry in the idenv
1760              -- NB: *** KNOT-TYING ***
1761             let
1762                 nenv_plus_id    = NmbrEnv (incrUnique ui) ut uu
1763                                           (addToUFM_Directly idenv u new_id)
1764                                           tvenv uvenv
1765
1766                 (nenv2, new_ty)  = nmbrType     ty  nenv_plus_id
1767                 (nenv3, new_det) = nmbr_details det nenv2
1768
1769                 new_id = Id ui n new_ty new_det prag info
1770             in
1771             (nenv3, new_id)
1772
1773 nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1774   = case (lookupUFM_Directly idenv u) of
1775       Just xx -> (nenv, xx)
1776       Nothing ->
1777         if not (toplevelishId id) then
1778             trace "nmbrId: lookup failed" $
1779             (nenv, id)
1780         else
1781             let
1782                 (nenv2, new_ty)  = nmbrType     ty  nenv
1783                 (nenv3, new_det) = nmbr_details det nenv2
1784
1785                 new_id = Id u n new_ty new_det prag info
1786             in
1787             (nenv3, new_id)
1788
1789     -- used when renumbering TyCons to produce data decls...
1790 nmbrDataCon id@(Id _ _ _ (TupleConId _) _ _) nenv
1791   = (nenv, id) -- nothing to do for tuples
1792
1793 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)
1794   = case (lookupUFM_Directly idenv u) of
1795       Just xx -> trace "nmbrDataCon: in env???\n" (nenv, xx)
1796       Nothing ->
1797         let
1798             (nenv2, new_fields)  = (mapNmbr nmbrField  fields)  nenv
1799             (nenv3, new_arg_tys) = (mapNmbr nmbrType   arg_tys) nenv2
1800
1801             new_det = DataConId tag marks new_fields (bottom "tvs") (bottom "theta") new_arg_tys tc
1802             new_id  = Id u n (bottom "ty") new_det prag info
1803         in
1804         (nenv3, new_id)
1805   where
1806     bottom msg = panic ("nmbrDataCon"++msg)
1807
1808 ------------
1809 nmbr_details :: IdDetails -> NmbrM IdDetails
1810
1811 nmbr_details (DataConId tag marks fields tvs theta arg_tys tc)
1812   = mapNmbr nmbrTyVar  tvs      `thenNmbr` \ new_tvs ->
1813     mapNmbr nmbrField  fields   `thenNmbr` \ new_fields ->
1814     mapNmbr nmbr_theta theta    `thenNmbr` \ new_theta ->
1815     mapNmbr nmbrType   arg_tys  `thenNmbr` \ new_arg_tys ->
1816     returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_arg_tys tc)
1817   where
1818     nmbr_theta (c,t)
1819       = --nmbrClass c   `thenNmbr` \ new_c ->
1820         nmbrType  t     `thenNmbr` \ new_t ->
1821         returnNmbr (c, new_t)
1822
1823     -- ToDo:add more cases as needed
1824 nmbr_details other_details = returnNmbr other_details
1825
1826 ------------
1827 nmbrField (FieldLabel n ty tag)
1828   = nmbrType ty `thenNmbr` \ new_ty ->
1829     returnNmbr (FieldLabel n new_ty tag)
1830 \end{code}