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