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