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