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