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