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         -- "Environments" keyed off of Ids, and sets of Ids
  85         IdEnv(..),
  86         lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
  87         growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
  88         delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
  89         rngIdEnv, mapIdEnv,
  90
  91         -- and to make the interface self-sufficient...
  92         GenIdSet(..), IdSet(..)
  93     )-} where
  94
  95 import Ubiq
  96 import IdLoop   -- for paranoia checking
  97 import TyLoop   -- for paranoia checking
  98
  99 import Bag
 100 import Class            ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
 101 import CStrings         ( identToC, cSEP )
 102 import IdInfo
 103 import Maybes           ( maybeToBool )
 104 import Name             ( appendRdr, nameUnique, mkLocalName, isLocalName,
 105                           isLocallyDefinedName, isPreludeDefinedName,
 106                           mkTupleDataConName, mkCompoundName,
 107                           isLexSym, getLocalName,
 108                           isLocallyDefined, isPreludeDefined,
 109                           getOccName, moduleNamePair, origName, nameOf,
 110                           isExported, ExportFlag(..),
 111                           RdrName(..), Name
 112                         )
 113 import FieldLabel       ( fieldLabelName, FieldLabel{-instances-} )
 114 import PragmaInfo       ( PragmaInfo(..) )
 115 import PprType          ( getTypeString, typeMaybeString, specMaybeTysSuffix,
 116                           GenType, GenTyVar
 117                         )
 118 import PprStyle
 119 import Pretty
 120 import SrcLoc           ( mkBuiltinSrcLoc )
 121 import TyCon            ( TyCon, mkTupleTyCon, tyConDataCons )
 122 import Type             ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
 123                           applyTyCon, isPrimType, instantiateTy,
 124                           tyVarsOfType, applyTypeEnvToTy, typePrimRep,
 125                           GenType, ThetaType(..), TauType(..), Type(..)
 126                         )
 127 import TyVar            ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
 128 import UniqFM
 129 import UniqSet          -- practically all of it
 130 import UniqSupply       ( getBuiltinUniques )
 131 import Unique           ( pprUnique, showUnique,
 132                           Unique{-instance Ord3-}
 133                         )
 134 import Util             ( mapAccumL, nOfThem, zipEqual,
 135                           panic, panic#, pprPanic, assertPanic
 136                         )
 137 \end{code}
 138
 139 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
 140 follow.
 141
 142 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
 143 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
 144 strictness).  The essential info about different kinds of @Ids@ is
 145 in its @IdDetails@.
 146
 147 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
 148
 149 \begin{code}
 150 data GenId ty = Id
 151         Unique          -- Key for fast comparison
 152         ty              -- Id's type; used all the time;
 153         IdDetails       -- Stuff about individual kinds of Ids.
 154         PragmaInfo      -- Properties of this Id requested by programmer
 155                         -- eg specialise-me, inline-me
 156         IdInfo          -- Properties of this Id deduced by compiler
 157
 158 type Id = GenId Type
 159
 160 data StrictnessMark = MarkedStrict | NotMarkedStrict
 161
 162 data IdDetails
 163
 164   ---------------- Local values
 165
 166   = LocalId     Name            -- Local name; mentioned by the user
 167                 Bool            -- True <=> no free type vars
 168
 169   | SysLocalId  Name            -- Local name; made up by the compiler
 170                 Bool            -- as for LocalId
 171
 172   | SpecPragmaId Name           -- Local name; introduced by the compiler
 173                  (Maybe Id)     -- for explicit specid in pragma
 174                  Bool           -- as for LocalId
 175
 176   ---------------- Global values
 177
 178   | ImportedId  Name            -- Global name (Imported or Implicit); Id imported from an interface
 179
 180   | PreludeId   Name            -- Global name (Builtin);  Builtin prelude Ids
 181
 182   | TopLevId    Name            -- Global name (LocalDef); Top-level in the orig source pgm
 183                                 -- (not moved there by transformations).
 184
 185         -- a TopLevId's type may contain free type variables, if
 186         -- the monomorphism restriction applies.
 187
 188   ---------------- Data constructors
 189
 190   | DataConId   Name
 191                 ConTag
 192                 [StrictnessMark] -- Strict args; length = arity
 193                 [FieldLabel]    -- Field labels for this constructor
 194
 195                 [TyVar] [(Class,Type)] [Type] TyCon
 196                                 -- the type is:
 197                                 -- forall tyvars . theta_ty =>
 198                                 --    unitype_1 -> ... -> unitype_n -> tycon tyvars
 199
 200   | TupleConId  Name
 201                 Int             -- Its arity
 202
 203   | RecordSelId FieldLabel
 204
 205   ---------------- Things to do with overloading
 206
 207   | SuperDictSelId              -- Selector for superclass dictionary
 208                 Class           -- The class (input dict)
 209                 Class           -- The superclass (result dict)
 210
 211   | MethodSelId Class           -- An overloaded class operation, with
 212                                 -- a fully polymorphic type.  Its code
 213                                 -- just selects a method from the
 214                                 -- dictionary.  The class.
 215                 ClassOp         -- The operation
 216
 217         -- NB: The IdInfo for a MethodSelId has all the info about its
 218         -- related "constant method Ids", which are just
 219         -- specialisations of this general one.
 220
 221   | DefaultMethodId             -- Default method for a particular class op
 222                 Class           -- same class, <blah-blah> info as MethodSelId
 223                 ClassOp         -- (surprise, surprise)
 224                 Bool            -- True <=> I *know* this default method Id
 225                                 -- is a generated one that just says
 226                                 -- `error "No default method for <op>"'.
 227
 228                                 -- see below
 229   | DictFunId   Class           -- A DictFun is uniquely identified
 230                 Type            -- by its class and type; this type has free type vars,
 231                                 -- whose identity is irrelevant.  Eg Class = Eq
 232                                 --                                   Type  = Tree a
 233                                 -- The "a" is irrelevant.  As it is too painful to
 234                                 -- actually do comparisons that way, we kindly supply
 235                                 -- a Unique for that purpose.
 236                 Bool            -- True <=> from an instance decl in this mod
 237                 (Maybe Module)  -- module where instance came from; Nothing => Prelude
 238
 239                                 -- see below
 240   | ConstMethodId               -- A method which depends only on the type of the
 241                                 -- instance, and not on any further dictionaries etc.
 242                 Class           -- Uniquely identified by:
 243                 Type            -- (class, type, classop) triple
 244                 ClassOp
 245                 Bool            -- True => from an instance decl in this mod
 246                 (Maybe Module)  -- module where instance came from; Nothing => Prelude
 247
 248   | InstId      Name            -- An instance of a dictionary, class operation,
 249                                 -- or overloaded value (Local name)
 250                 Bool            -- as for LocalId
 251
 252   | SpecId                      -- A specialisation of another Id
 253                 Id              -- Id of which this is a specialisation
 254                 [Maybe Type]    -- Types at which it is specialised;
 255                                 -- A "Nothing" says this type ain't relevant.
 256                 Bool            -- True <=> no free type vars; it's not enough
 257                                 -- to know about the unspec version, because
 258                                 -- we may specialise to a type w/ free tyvars
 259                                 -- (i.e., in one of the "Maybe Type" dudes).
 260
 261   | WorkerId                    -- A "worker" for some other Id
 262                 Id              -- Id for which this is a worker
 263
 264
 265 type ConTag     = Int
 266 type DictVar    = Id
 267 type DictFun    = Id
 268 type DataCon    = Id
 269 \end{code}
 270
 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 ty d p i) = Id u (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
 486 nested @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 (InstId       _   no_free_tvs) = no_free_tvs
 533     chk (SpecId _     _   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 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 _ _ False _) = 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 ty info (TopLevId fn))
 849   = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
 850
 851 unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
 852   = --false?: ASSERT(no_ftvs)
 853     let
 854         full_name = unlocaliseShortName mod u sn
 855     in
 856     Just (Id u ty info (TopLevId full_name))
 857
 858 unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
 859   = --false?: on PreludeGlaST: ASSERT(no_ftvs)
 860     let
 861         full_name = unlocaliseShortName mod u sn
 862     in
 863     Just (Id u ty info (TopLevId full_name))
 864
 865 unlocaliseId mod (Id u 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 ty info (SpecId xx ty_maybes no_ftvs))
 869
 870 unlocaliseId mod (Id u ty info (WorkerId unwrkr))
 871   = case unlocalise_parent mod u unwrkr of
 872       Nothing -> Nothing
 873       Just xx -> Just (Id u ty info (WorkerId xx))
 874
 875 unlocaliseId mod (Id u ty info (InstId name no_ftvs))
 876   = Just (Id u ty info (TopLevId full_name))
 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 _ ty info (LocalId sn no_ftvs))
 890   = --false?: ASSERT(no_ftvs)
 891     let
 892         full_name = unlocaliseShortName mod uniq sn
 893     in
 894     Just (Id uniq ty info (TopLevId full_name))
 895
 896 unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
 897   = --false?: ASSERT(no_ftvs)
 898     let
 899         full_name = unlocaliseShortName mod uniq sn
 900     in
 901     Just (Id uniq ty info (TopLevId full_name))
 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)
 931             -> Id
 932             -> Id
 933
 934 apply_to_Id ty_fn (Id u ty details prag info)
 935   = let
 936         new_ty = ty_fn ty
 937     in
 938     Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
 939   where
 940     apply_to_details (SpecId unspec ty_maybes no_ftvs)
 941       = let
 942             new_unspec = apply_to_Id ty_fn unspec
 943             new_maybes = map apply_to_maybe ty_maybes
 944         in
 945         SpecId new_unspec new_maybes (no_free_tvs ty)
 946         -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
 947       where
 948         apply_to_maybe Nothing   = Nothing
 949         apply_to_maybe (Just ty) = Just (ty_fn ty)
 950
 951     apply_to_details (WorkerId unwrkr)
 952       = let
 953             new_unwrkr = apply_to_Id ty_fn unwrkr
 954         in
 955         WorkerId new_unwrkr
 956
 957     apply_to_details other = other
 958 \end{code}
 959
 960 Sadly, I don't think the one using the magic typechecker substitution
 961 can be done with @apply_to_Id@.  Here we go....
 962
 963 Strictness is very important here.  We can't leave behind thunks
 964 with pointers to the substitution: it {\em must} be single-threaded.
 965
 966 \begin{code}
 967 {-LATER:
 968 applySubstToId :: Subst -> Id -> (Subst, Id)
 969
 970 applySubstToId subst id@(Id u ty info details)
 971   -- *cannot* have a "idHasNoFreeTyVars" get-out clause
 972   -- because, in the typechecker, we are still
 973   -- *concocting* the types.
 974   = case (applySubstToTy     subst ty)          of { (s2, new_ty)      ->
 975     case (applySubstToIdInfo s2    info)        of { (s3, new_info)    ->
 976     case (apply_to_details   s3 new_ty details) of { (s4, new_details) ->
 977     (s4, Id u new_ty new_info new_details) }}}
 978   where
 979     apply_to_details subst _ (InstId inst no_ftvs)
 980       = case (applySubstToInst subst inst) of { (s2, new_inst) ->
 981         (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
 982
 983     apply_to_details subst new_ty (SpecId unspec ty_maybes _)
 984       = case (applySubstToId subst unspec)           of { (s2, new_unspec) ->
 985         case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
 986         (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
 987         -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
 988       where
 989         apply_to_maybe subst Nothing   = (subst, Nothing)
 990         apply_to_maybe subst (Just ty)
 991           = case (applySubstToTy subst ty) of { (s2, new_ty) ->
 992             (s2, Just new_ty) }
 993
 994     apply_to_details subst _ (WorkerId unwrkr)
 995       = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
 996         (s2, WorkerId new_unwrkr) }
 997
 998     apply_to_details subst _ other = (subst, other)
 999 -}
1000 \end{code}
1001
1002 \begin{code}
1003 getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
1004
1005 getIdNamePieces show_uniqs id
1006   = get (unsafeGenId2Id id)
1007   where
1008   get (Id u _ details _ _)
1009     = case details of
1010       DataConId n _ _ _ _ _ _ _ ->
1011         case (moduleNamePair n) of { (mod, name) ->
1012         if isPreludeDefinedName n then [name] else [mod, name] }
1013
1014       TupleConId n _ -> [nameOf (origName n)]
1015
1016       RecordSelId lbl ->
1017         let n = fieldLabelName lbl
1018         in
1019         case (moduleNamePair n) of { (mod, name) ->
1020         if isPreludeDefinedName n then [name] else [mod, name] }
1021
1022       ImportedId n -> get_fullname_pieces n
1023       PreludeId  n -> get_fullname_pieces n
1024       TopLevId   n -> get_fullname_pieces n
1025
1026       SuperDictSelId c sc ->
1027         case (moduleNamePair c) of { (c_mod, c_name) ->
1028         case (moduleNamePair sc)        of { (sc_mod, sc_name) ->
1029         let
1030             c_bits = if isPreludeDefined c
1031                      then [c_name]
1032                      else [c_mod, c_name]
1033
1034             sc_bits= if isPreludeDefined sc
1035                      then [sc_name]
1036                      else [sc_mod, sc_name]
1037         in
1038         [SLIT("sdsel")] ++ c_bits ++ sc_bits  }}
1039
1040       MethodSelId clas op ->
1041         case (moduleNamePair clas)      of { (c_mod, c_name) ->
1042         case (classOpString op) of { op_name ->
1043         if isPreludeDefined clas
1044         then [op_name]
1045         else [c_mod, c_name, op_name]
1046         } }
1047
1048       DefaultMethodId clas op _ ->
1049         case (moduleNamePair clas)              of { (c_mod, c_name) ->
1050         case (classOpString op) of { op_name ->
1051         if isPreludeDefined clas
1052         then [SLIT("defm"), op_name]
1053         else [SLIT("defm"), c_mod, c_name, op_name] }}
1054
1055       DictFunId c ty _ _ ->
1056         case (moduleNamePair c)     of { (c_mod, c_name) ->
1057         let
1058             c_bits = if isPreludeDefined c
1059                      then [c_name]
1060                      else [c_mod, c_name]
1061
1062             ty_bits = getTypeString ty
1063         in
1064         [SLIT("dfun")] ++ c_bits ++ ty_bits }
1065
1066       ConstMethodId c ty o _ _ ->
1067         case (moduleNamePair c)     of { (c_mod, c_name) ->
1068         case (getTypeString ty)     of { ty_bits ->
1069         case (classOpString o)   of { o_name ->
1070         case (if isPreludeDefined c
1071               then [c_name]
1072               else [c_mod, c_name]) of { c_bits ->
1073         [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
1074
1075       -- if the unspecialised equiv is "top-level",
1076       -- the name must be concocted from its name and the
1077       -- names of the types to which specialised...
1078
1079       SpecId unspec ty_maybes _ ->
1080         get unspec ++ (if not (toplevelishId unspec)
1081                        then [showUnique u]
1082                        else concat (map typeMaybeString ty_maybes))
1083
1084       WorkerId unwrkr ->
1085         get unwrkr ++ (if not (toplevelishId unwrkr)
1086                        then [showUnique u]
1087                        else [SLIT("wrk")])
1088
1089       LocalId      n _   -> let local = getLocalName n in
1090                             if show_uniqs then [local, showUnique u] else [local]
1091       InstId       n _   -> [getLocalName n, showUnique u]
1092       SysLocalId   n _   -> [getLocalName n, showUnique u]
1093       SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
1094
1095 get_fullname_pieces :: Name -> [FAST_STRING]
1096 get_fullname_pieces n
1097   = BIND (moduleNamePair n) _TO_ (mod, name) ->
1098     if isPreludeDefinedName n
1099     then [name]
1100     else [mod, name]
1101     BEND
1102 \end{code}
1103
1104 %************************************************************************
1105 %*                                                                      *
1106 \subsection[Id-type-funs]{Type-related @Id@ functions}
1107 %*                                                                      *
1108 %************************************************************************
1109
1110 \begin{code}
1111 idType :: GenId ty -> ty
1112
1113 idType (Id _ ty _ _ _) = ty
1114 \end{code}
1115
1116 \begin{code}
1117 {-LATER:
1118 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1119
1120 getMentionedTyConsAndClassesFromId id
1121  = getMentionedTyConsAndClassesFromType (idType id)
1122 -}
1123 \end{code}
1124
1125 \begin{code}
1126 idPrimRep i = typePrimRep (idType i)
1127 \end{code}
1128
1129 \begin{code}
1130 {-LATER:
1131 getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
1132 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
1133 getInstIdModule other = panic "Id:getInstIdModule"
1134 -}
1135 \end{code}
1136
1137 %************************************************************************
1138 %*                                                                      *
1139 \subsection[Id-overloading]{Functions related to overloading}
1140 %*                                                                      *
1141 %************************************************************************
1142
1143 \begin{code}
1144 mkSuperDictSelId  u c sc     ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
1145 mkMethodSelId     u c op     ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
1146 mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
1147
1148 mkDictFunId u c ity full_ty from_here mod info
1149   = Id u full_ty (DictFunId c ity from_here mod) NoPragmaInfo info
1150
1151 mkConstMethodId u c op ity full_ty from_here mod info
1152   = Id u full_ty (ConstMethodId c ity op from_here mod) NoPragmaInfo info
1153
1154 mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
1155
1156 mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo
1157
1158 {-LATER:
1159 getConstMethodId clas op ty
1160   = -- constant-method info is hidden in the IdInfo of
1161     -- the class-op id (as mentioned up above).
1162     let
1163         sel_id = getMethodSelId clas op
1164     in
1165     case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1166       Just xx -> xx
1167       Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
1168         ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1169                ppr PprDebug sel_id],
1170         ppStr "(This can arise if an interface pragma refers to an instance",
1171         ppStr "but there is no imported interface which *defines* that instance.",
1172         ppStr "The info above, however ugly, should indicate what else you need to import."
1173         ])
1174 -}
1175 \end{code}
1176
1177 %************************************************************************
1178 %*                                                                      *
1179 \subsection[local-funs]{@LocalId@-related functions}
1180 %*                                                                      *
1181 %************************************************************************
1182
1183 \begin{code}
1184 mkImported  n ty info = Id (nameUnique n) ty (ImportedId n) NoPragmaInfo info
1185 mkPreludeId n ty info = Id (nameUnique n) ty (PreludeId  n) NoPragmaInfo info
1186
1187 {-LATER:
1188 updateIdType :: Id -> Type -> Id
1189 updateIdType (Id u _ info details) ty = Id u ty info details
1190 -}
1191 \end{code}
1192
1193 \begin{code}
1194 type MyTy a b = GenType (GenTyVar a) b
1195 type MyId a b = GenId (MyTy a b)
1196
1197 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1198
1199 -- SysLocal: for an Id being created by the compiler out of thin air...
1200 -- UserLocal: an Id with a name the user might recognize...
1201 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1202
1203 mkSysLocal str uniq ty loc
1204   = Id uniq ty (SysLocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1205
1206 mkUserLocal str uniq ty loc
1207   = Id uniq ty (LocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1208
1209 -- mkUserId builds a local or top-level Id, depending on the name given
1210 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1211 mkUserId name ty pragma_info
1212   | isLocalName name
1213   = Id (nameUnique name) ty (LocalId name (no_free_tvs ty)) pragma_info noIdInfo
1214   | otherwise
1215   = Id (nameUnique name) ty
1216        (if isLocallyDefinedName name then TopLevId name else ImportedId name)
1217         pragma_info noIdInfo
1218 \end{code}
1219
1220
1221 \begin{code}
1222 {-LATER:
1223
1224 -- for a SpecPragmaId being created by the compiler out of thin air...
1225 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1226 mkSpecPragmaId str uniq ty specid loc
1227   = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
1228
1229 -- for new SpecId
1230 mkSpecId u unspec ty_maybes ty info
1231   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1232     Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1233
1234 -- Specialised version of constructor: only used in STG and code generation
1235 -- Note: The specialsied Id has the same unique as the unspeced Id
1236
1237 mkSameSpecCon ty_maybes unspec@(Id u ty info details)
1238   = ASSERT(isDataCon unspec)
1239     ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1240     Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1241   where
1242     new_ty = specialiseTy ty ty_maybes 0
1243
1244 localiseId :: Id -> Id
1245 localiseId id@(Id u ty info details)
1246   = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
1247   where
1248     name = getOccName id
1249     loc  = getSrcLoc id
1250 -}
1251
1252 mkIdWithNewUniq :: Id -> Unique -> Id
1253
1254 mkIdWithNewUniq (Id _ ty details prag info) uniq
1255   = Id uniq ty details prag info
1256 \end{code}
1257
1258 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
1259 @Uniques@, but that's OK because the templates are supposed to be
1260 instantiated before use.
1261 \begin{code}
1262 mkTemplateLocals :: [Type] -> [Id]
1263 mkTemplateLocals tys
1264   = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1265             (getBuiltinUniques (length tys))
1266             tys
1267 \end{code}
1268
1269 \begin{code}
1270 getIdInfo     :: GenId ty -> IdInfo
1271 getPragmaInfo :: GenId ty -> PragmaInfo
1272
1273 getIdInfo     (Id _ _ _ _ info) = info
1274 getPragmaInfo (Id _ _ _ info _) = info
1275
1276 {-LATER:
1277 replaceIdInfo :: Id -> IdInfo -> Id
1278
1279 replaceIdInfo (Id u ty _ details) info = Id u ty info details
1280
1281 selectIdInfoForSpecId :: Id -> IdInfo
1282 selectIdInfoForSpecId unspec
1283   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1284     noIdInfo `addInfo_UF` getIdUnfolding unspec
1285 -}
1286 \end{code}
1287
1288 %************************************************************************
1289 %*                                                                      *
1290 \subsection[Id-arities]{Arity-related functions}
1291 %*                                                                      *
1292 %************************************************************************
1293
1294 For locally-defined Ids, the code generator maintains its own notion
1295 of their arities; so it should not be asking...  (but other things
1296 besides the code-generator need arity info!)
1297
1298 \begin{code}
1299 getIdArity :: Id -> ArityInfo
1300 getIdArity (Id _ _ _ _ id_info)  = getInfo id_info
1301
1302 dataConArity :: DataCon -> Int
1303 dataConArity id@(Id _ _ _ _ id_info)
1304   = ASSERT(isDataCon id)
1305     case (arityMaybe (getInfo id_info)) of
1306       Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1307       Just  i -> i
1308
1309 addIdArity :: Id -> Int -> Id
1310 addIdArity (Id u ty details pinfo info) arity
1311   = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
1312 \end{code}
1313
1314 %************************************************************************
1315 %*                                                                      *
1316 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1317 %*                                                                      *
1318 %************************************************************************
1319
1320 \begin{code}
1321 mkDataCon :: Name
1322           -> [StrictnessMark] -> [FieldLabel]
1323           -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1324 --ToDo:   -> SpecEnv
1325           -> Id
1326   -- can get the tag and all the pieces of the type from the Type
1327
1328 mkDataCon n stricts fields tvs ctxt args_tys tycon
1329   = ASSERT(length stricts == length args_tys)
1330     data_con
1331   where
1332     -- NB: data_con self-recursion; should be OK as tags are not
1333     -- looked at until late in the game.
1334     data_con
1335       = Id (nameUnique n)
1336            type_of_constructor
1337            (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon)
1338            NoPragmaInfo
1339            datacon_info
1340
1341     data_con_tag    = position_within fIRST_TAG data_con_family
1342
1343     data_con_family = tyConDataCons tycon
1344
1345     position_within :: Int -> [Id] -> Int
1346
1347     position_within acc (c:cs)
1348       = if c == data_con then acc else position_within (acc+1) cs
1349 #ifdef DEBUG
1350     position_within acc []
1351       = panic "mkDataCon: con not found in family"
1352 #endif
1353
1354     type_of_constructor
1355       = mkSigmaTy tvs ctxt
1356         (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1357
1358     datacon_info = noIdInfo `addInfo_UF` unfolding
1359                             `addInfo` mkArityInfo arity
1360 --ToDo:                     `addInfo` specenv
1361
1362     arity = length args_tys
1363
1364     unfolding
1365       = noInfo_UF
1366 {- LATER:
1367       = -- if arity == 0
1368         -- then noIdInfo
1369         -- else -- do some business...
1370         let
1371             (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1372             tyvar_tys = mkTyVarTys tyvars
1373         in
1374         BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1375
1376         mkUnfolding EssentialUnfolding -- for data constructors
1377                     (mkLam tyvars (dict_vars ++ vars) plain_Con)
1378         BEND
1379
1380     mk_uf_bits tvs ctxt arg_tys tycon
1381       = let
1382             (inst_env, tyvars, tyvar_tys)
1383               = instantiateTyVarTemplates tvs
1384                                           (map uniqueOf tvs)
1385         in
1386             -- the "context" and "arg_tys" have TyVarTemplates in them, so
1387             -- we instantiate those types to have the right TyVars in them
1388             -- instead.
1389         BIND (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1390                                                         _TO_ inst_dict_tys ->
1391         BIND (map (instantiateTauTy inst_env) arg_tys)  _TO_ inst_arg_tys ->
1392
1393             -- We can only have **ONE** call to mkTemplateLocals here;
1394             -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1395             -- (Mega-Sigh) [ToDo]
1396         BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars ->
1397
1398         BIND (splitAt (length ctxt) all_vars)   _TO_ (dict_vars, vars) ->
1399
1400         (tyvars, dict_vars, vars)
1401         BEND BEND BEND BEND
1402       where
1403         -- these are really dubious Types, but they are only to make the
1404         -- binders for the lambdas for tossed-away dicts.
1405         ctxt_ty (clas, ty) = mkDictTy clas ty
1406 -}
1407 \end{code}
1408
1409 \begin{code}
1410 mkTupleCon :: Arity -> Id
1411
1412 mkTupleCon arity
1413   = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info
1414   where
1415     n           = mkTupleDataConName arity
1416     unique      = uniqueOf n
1417     ty          = mkSigmaTy tyvars []
1418                    (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1419     tycon       = mkTupleTyCon arity
1420     tyvars      = take arity alphaTyVars
1421     tyvar_tys   = mkTyVarTys tyvars
1422
1423     tuplecon_info
1424       = noIdInfo `addInfo_UF` unfolding
1425                  `addInfo` mkArityInfo arity
1426 --LATER:?        `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1427
1428     unfolding
1429       = noInfo_UF
1430 {- LATER:
1431       = -- if arity == 0
1432         -- then noIdInfo
1433         -- else -- do some business...
1434         let
1435             (tyvars, dict_vars, vars) = mk_uf_bits arity
1436             tyvar_tys = mkTyVarTys tyvars
1437         in
1438         BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
1439
1440         mkUnfolding
1441             EssentialUnfolding    -- data constructors
1442             (mkLam tyvars (dict_vars ++ vars) plain_Con)
1443         BEND
1444
1445     mk_uf_bits arity
1446       = BIND (mkTemplateLocals tyvar_tys)                _TO_ vars ->
1447         (tyvars, [], vars)
1448         BEND
1449       where
1450         tyvar_tmpls     = take arity alphaTyVars
1451         (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
1452 -}
1453
1454 fIRST_TAG :: ConTag
1455 fIRST_TAG =  1  -- Tags allocated from here for real constructors
1456 \end{code}
1457
1458 \begin{code}
1459 dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
1460 dataConTag      (Id _ _ (DataConId _ tag _ _ _ _ _ _) _ _) = tag
1461 dataConTag      (Id _ _ (TupleConId _ _) _ _)            = fIRST_TAG
1462 dataConTag      (Id _ _ (SpecId unspec _ _) _ _)         = dataConTag unspec
1463
1464 dataConTyCon :: DataCon -> TyCon        -- will panic if not a DataCon
1465 dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon
1466 dataConTyCon (Id _ _ (TupleConId _ a) _ _)                 = mkTupleTyCon a
1467
1468 dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
1469                                         -- will panic if not a DataCon
1470
1471 dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _)
1472   = (tyvars, theta_ty, arg_tys, tycon)
1473
1474 dataConSig (Id _ _ (TupleConId _ arity) _ _)
1475   = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
1476   where
1477     tyvars      = take arity alphaTyVars
1478     tyvar_tys   = mkTyVarTys tyvars
1479
1480 dataConFieldLabels :: DataCon -> [FieldLabel]
1481 dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields
1482 dataConFieldLabels (Id _ _ (TupleConId _ _)                 _ _) = []
1483
1484 dataConStrictMarks :: DataCon -> [StrictnessMark]
1485 dataConStrictMarks (Id _ _ (DataConId _ _ stricts _ _ _ _ _) _ _) = stricts
1486 dataConStrictMarks (Id _ _ (TupleConId _ arity)              _ _)
1487   = take arity (repeat NotMarkedStrict)
1488
1489 dataConArgTys :: DataCon
1490               -> [Type]         -- Instantiated at these types
1491               -> [Type]         -- Needs arguments of these types
1492 dataConArgTys con_id inst_tys
1493  = map (instantiateTy tenv) arg_tys
1494  where
1495     (tyvars, _, arg_tys, _) = dataConSig con_id
1496     tenv                    = tyvars `zipEqual` inst_tys
1497 \end{code}
1498
1499 \begin{code}
1500 mkRecordSelId field_label selector_ty
1501   = Id (nameUnique name)
1502        selector_ty
1503        (RecordSelId field_label)
1504        NoPragmaInfo
1505        noIdInfo
1506   where
1507     name = fieldLabelName field_label
1508
1509 recordSelectorFieldLabel :: Id -> FieldLabel
1510 recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl
1511 \end{code}
1512
1513
1514 Data type declarations are of the form:
1515 \begin{verbatim}
1516 data Foo a b = C1 ... | C2 ... | ... | Cn ...
1517 \end{verbatim}
1518 For each constructor @Ci@, we want to generate a curried function; so, e.g., for
1519 @C1 x y z@, we want a function binding:
1520 \begin{verbatim}
1521 fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
1522 \end{verbatim}
1523 Notice the ``big lambdas'' and type arguments to @Con@---we are producing
1524 2nd-order polymorphic lambda calculus with explicit types.
1525
1526 %************************************************************************
1527 %*                                                                      *
1528 \subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
1529 %*                                                                      *
1530 %************************************************************************
1531
1532 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
1533 and generates an @UnfoldingDetails@ for its unfolding.  The @Ids@ and
1534 @TyVars@ don't really have to be new, because we are only producing a
1535 template.
1536
1537 ToDo: what if @DataConId@'s type has a context (haven't thought about it
1538 --WDP)?
1539
1540 Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
1541 EXPORTED.  It just returns the binders (@TyVars@ and @Ids@) [in the
1542 example above: a, b, and x, y, z], which is enough (in the important
1543 \tr{DsExpr} case).  (The middle set of @Ids@ is binders for any
1544 dictionaries, in the even of an overloaded data-constructor---none at
1545 present.)
1546
1547 \begin{code}
1548 getIdUnfolding :: Id -> UnfoldingDetails
1549
1550 getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info
1551
1552 {-LATER:
1553 addIdUnfolding :: Id -> UnfoldingDetails -> Id
1554 addIdUnfolding id@(Id u ty info details) unfold_details
1555   = ASSERT(
1556         case (isLocallyDefined id, unfold_details) of
1557         (_,     NoUnfoldingDetails) -> True
1558         (True,  IWantToBeINLINEd _) -> True
1559         (False, IWantToBeINLINEd _) -> False -- v bad
1560         (False, _)                  -> True
1561         _                           -> False -- v bad
1562     )
1563     Id u ty (info `addInfo_UF` unfold_details) details
1564 -}
1565 \end{code}
1566
1567 In generating selector functions (take a dictionary, give back one
1568 component...), we need to what out for the nothing-to-select cases (in
1569 which case the ``selector'' is just an identity function):
1570 \begin{verbatim}
1571 class Eq a => Foo a { }     # the superdict selector for "Eq"
1572
1573 class Foo a { op :: Complex b => c -> b -> a }
1574                             # the method selector for "op";
1575                             # note local polymorphism...
1576 \end{verbatim}
1577
1578 %************************************************************************
1579 %*                                                                      *
1580 \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@}
1581 %*                                                                      *
1582 %************************************************************************
1583
1584 \begin{code}
1585 getIdDemandInfo :: Id -> DemandInfo
1586 getIdDemandInfo (Id _ _ _ _ info) = getInfo info
1587
1588 addIdDemandInfo :: Id -> DemandInfo -> Id
1589 addIdDemandInfo (Id u ty details prags info) demand_info
1590   = Id u ty details prags (info `addInfo` demand_info)
1591 \end{code}
1592
1593 \begin{code}
1594 getIdUpdateInfo :: Id -> UpdateInfo
1595 getIdUpdateInfo (Id _ _ _ _ info) = getInfo info
1596
1597 addIdUpdateInfo :: Id -> UpdateInfo -> Id
1598 addIdUpdateInfo (Id u ty details prags info) upd_info
1599   = Id u ty details prags (info `addInfo` upd_info)
1600 \end{code}
1601
1602 \begin{code}
1603 {- LATER:
1604 getIdArgUsageInfo :: Id -> ArgUsageInfo
1605 getIdArgUsageInfo (Id u ty info details) = getInfo info
1606
1607 addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
1608 addIdArgUsageInfo (Id u ty info details) au_info
1609   = Id u ty (info `addInfo` au_info) details
1610 -}
1611 \end{code}
1612
1613 \begin{code}
1614 {- LATER:
1615 getIdFBTypeInfo :: Id -> FBTypeInfo
1616 getIdFBTypeInfo (Id u ty info details) = getInfo info
1617
1618 addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
1619 addIdFBTypeInfo (Id u ty info details) upd_info
1620   = Id u ty (info `addInfo` upd_info) details
1621 -}
1622 \end{code}
1623
1624 \begin{code}
1625 {- LATER:
1626 getIdSpecialisation :: Id -> SpecEnv
1627 getIdSpecialisation (Id _ _ _ _ info) = getInfo info
1628
1629 addIdSpecialisation :: Id -> SpecEnv -> Id
1630 addIdSpecialisation (Id u ty details prags info) spec_info
1631   = Id u ty details prags (info `addInfo` spec_info)
1632 -}
1633 \end{code}
1634
1635 Strictness: we snaffle the info out of the IdInfo.
1636
1637 \begin{code}
1638 getIdStrictness :: Id -> StrictnessInfo
1639
1640 getIdStrictness (Id _ _ _ _ info) = getInfo info
1641
1642 addIdStrictness :: Id -> StrictnessInfo -> Id
1643
1644 addIdStrictness (Id u ty details prags info) strict_info
1645   = Id u ty details prags (info `addInfo` strict_info)
1646 \end{code}
1647
1648 %************************************************************************
1649 %*                                                                      *
1650 \subsection[Id-comparison]{Comparison functions for @Id@s}
1651 %*                                                                      *
1652 %************************************************************************
1653
1654 Comparison: equality and ordering---this stuff gets {\em hammered}.
1655
1656 \begin{code}
1657 cmpId (Id u1 _ _ _ _) (Id u2 _ _ _ _) = cmp u1 u2
1658 -- short and very sweet
1659 \end{code}
1660
1661 \begin{code}
1662 instance Ord3 (GenId ty) where
1663     cmp = cmpId
1664
1665 instance Eq (GenId ty) where
1666     a == b = case cmpId a b of { EQ_ -> True;  _ -> False }
1667     a /= b = case cmpId a b of { EQ_ -> False; _ -> True  }
1668
1669 instance Ord (GenId ty) where
1670     a <= b = case cmpId a b of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
1671     a <  b = case cmpId a b of { LT_ -> True;  EQ_ -> False; GT__ -> False }
1672     a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
1673     a >  b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True  }
1674     _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
1675 \end{code}
1676
1677 @cmpId_withSpecDataCon@ ensures that any spectys are taken into
1678 account when comparing two data constructors. We need to do this
1679 because a specialised data constructor has the same Unique as its
1680 unspecialised counterpart.
1681
1682 \begin{code}
1683 cmpId_withSpecDataCon :: Id -> Id -> TAG_
1684
1685 cmpId_withSpecDataCon id1 id2
1686   | eq_ids && isDataCon id1 && isDataCon id2
1687   = cmpEqDataCon id1 id2
1688
1689   | otherwise
1690   = cmp_ids
1691   where
1692     cmp_ids = cmpId id1 id2
1693     eq_ids  = case cmp_ids of { EQ_ -> True; other -> False }
1694
1695 cmpEqDataCon (Id _ _ (SpecId _ mtys1 _) _ _) (Id _ _ (SpecId _ mtys2 _) _ _)
1696   = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2"
1697
1698 cmpEqDataCon _ (Id _ _ (SpecId _ _ _) _ _) = LT_
1699 cmpEqDataCon (Id _ _ (SpecId _ _ _) _ _) _ = GT_
1700 cmpEqDataCon _                           _ = EQ_
1701 \end{code}
1702
1703 %************************************************************************
1704 %*                                                                      *
1705 \subsection[Id-other-instances]{Other instance declarations for @Id@s}
1706 %*                                                                      *
1707 %************************************************************************
1708
1709 \begin{code}
1710 instance Outputable ty => Outputable (GenId ty) where
1711     ppr sty id = pprId sty id
1712
1713 -- and a SPECIALIZEd one:
1714 instance Outputable {-Id, i.e.:-}(GenId Type) where
1715     ppr sty id = pprId sty id
1716
1717 showId :: PprStyle -> Id -> String
1718 showId sty id = ppShow 80 (pprId sty id)
1719
1720 -- [used below]
1721 -- for DictFuns (instances) and const methods (instance code bits we
1722 -- can call directly): exported (a) if *either* the class or
1723 -- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
1724 -- class and tycon are from PreludeCore [non-std, but convenient]
1725 -- *and* the thing was defined in this module.
1726
1727 instance_export_flag :: Class -> Type -> Bool -> ExportFlag
1728
1729 instance_export_flag clas inst_ty from_here
1730   = panic "Id:instance_export_flag"
1731 {-LATER
1732   = if instanceIsExported clas inst_ty from_here
1733     then ExportAll
1734     else NotExported
1735 -}
1736 \end{code}
1737
1738 Default printing code (not used for interfaces):
1739 \begin{code}
1740 pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
1741
1742 pprId other_sty id
1743   = let
1744         pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id
1745
1746         for_code
1747           = let
1748                 pieces_to_print -- maybe use Unique only
1749                   = if isSysLocalId id then tail pieces else pieces
1750             in
1751             ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print)
1752     in
1753     case other_sty of
1754       PprForC         -> for_code
1755       PprForAsm _ _   -> for_code
1756       PprInterface    -> ppr other_sty occur_name
1757       PprForUser      -> ppr other_sty occur_name
1758       PprUnfolding    -> qualified_name pieces
1759       PprDebug        -> qualified_name pieces
1760       PprShowAll      -> ppBesides [qualified_name pieces,
1761                             (ppCat [pp_uniq id,
1762                                     ppPStr SLIT("{-"),
1763                                     ppr other_sty (idType id),
1764                                     ppIdInfo other_sty (unsafeGenId2Id id) True
1765                                              (\x->x) nullIdEnv (getIdInfo id),
1766                                     ppPStr SLIT("-}") ])]
1767   where
1768     occur_name = getOccName id  `appendRdr`
1769                  (if not (isSysLocalId id)
1770                   then SLIT("")
1771                   else SLIT(".") _APPEND_ (showUnique (idUnique id)))
1772
1773     qualified_name pieces
1774       = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
1775
1776     pp_uniq (Id _ _ (PreludeId _) _ _)             = ppNil -- no uniq to add
1777     pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = ppNil
1778     pp_uniq (Id _ _ (TupleConId _ _) _ _)          = ppNil
1779     pp_uniq (Id _ _ (LocalId _ _) _ _)             = ppNil -- uniq printed elsewhere
1780     pp_uniq (Id _ _ (SysLocalId _ _) _ _)          = ppNil
1781     pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _)      = ppNil
1782     pp_uniq (Id _ _ (InstId _ _) _ _)              = ppNil
1783     pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (idUnique other_id), ppPStr SLIT("-}")]
1784
1785     -- print PprDebug Ids with # afterwards if they are of primitive type.
1786     pp_ubxd pretty = pretty
1787
1788 {- LATER: applying isPrimType restricts type
1789     pp_ubxd pretty = if isPrimType (idType id)
1790                      then ppBeside pretty (ppChar '#')
1791                      else pretty
1792 -}
1793
1794 \end{code}
1795
1796 \begin{code}
1797 idUnique (Id u _ _ _ _) = u
1798
1799 instance Uniquable (GenId ty) where
1800     uniqueOf = idUnique
1801
1802 instance NamedThing (GenId ty) where
1803     getName this_id@(Id u _ details _ _)
1804       = get details
1805       where
1806         get (LocalId      n _)          = n
1807         get (SysLocalId   n _)          = n
1808         get (SpecPragmaId n _ _)        = n
1809         get (ImportedId   n)            = n
1810         get (PreludeId    n)            = n
1811         get (TopLevId     n)            = n
1812         get (InstId       n _)          = n
1813         get (DataConId n _ _ _ _ _ _ _) = n
1814         get (TupleConId n _)            = n
1815         get (RecordSelId l)             = getName l
1816         get _                           = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id)
1817
1818 {- LATER:
1819         get (MethodSelId c op)  = case (moduleOf (origName c)) of -- ToDo; better ???
1820                                     mod -> (mod, classOpString op)
1821
1822         get (SpecId unspec ty_maybes _)
1823           = BIND moduleNamePair unspec        _TO_ (mod, unspec_nm) ->
1824             BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
1825             (mod,
1826              unspec_nm _APPEND_
1827                 (if not (toplevelishId unspec)
1828                  then showUnique u
1829                  else tys_suffix)
1830             )
1831             BEND BEND
1832
1833         get (WorkerId unwrkr)
1834           = BIND moduleNamePair unwrkr  _TO_ (mod, unwrkr_nm) ->
1835             (mod,
1836              unwrkr_nm _APPEND_
1837                 (if not (toplevelishId unwrkr)
1838                  then showUnique u
1839                  else SLIT(".wrk"))
1840             )
1841             BEND
1842
1843         get other_details
1844             -- the remaining internally-generated flavours of
1845             -- Ids really do not have meaningful "original name" stuff,
1846             -- but we need to make up something (usually for debugging output)
1847
1848           = BIND (getIdNamePieces True this_id)  _TO_ (piece1:pieces) ->
1849             BIND [ _CONS_ '.' p | p <- pieces ]  _TO_ dotted_pieces ->
1850             (_NIL_, _CONCAT_ (piece1 : dotted_pieces))
1851             BEND BEND
1852 -}
1853 \end{code}
1854
1855 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1856 the @Uniques@ out of local @Ids@ given to it.
1857
1858 %************************************************************************
1859 %*                                                                      *
1860 \subsection{@IdEnv@s and @IdSet@s}
1861 %*                                                                      *
1862 %************************************************************************
1863
1864 \begin{code}
1865 type IdEnv elt = UniqFM elt
1866
1867 nullIdEnv         :: IdEnv a
1868
1869 mkIdEnv           :: [(GenId ty, a)] -> IdEnv a
1870 unitIdEnv         :: GenId ty -> a -> IdEnv a
1871 addOneToIdEnv     :: IdEnv a -> GenId ty -> a -> IdEnv a
1872 growIdEnv         :: IdEnv a -> IdEnv a -> IdEnv a
1873 growIdEnvList     :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1874
1875 delManyFromIdEnv  :: IdEnv a -> [GenId ty] -> IdEnv a
1876 delOneFromIdEnv   :: IdEnv a -> GenId ty -> IdEnv a
1877 combineIdEnvs     :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1878 mapIdEnv          :: (a -> b) -> IdEnv a -> IdEnv b
1879 modifyIdEnv       :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
1880 rngIdEnv          :: IdEnv a -> [a]
1881
1882 isNullIdEnv       :: IdEnv a -> Bool
1883 lookupIdEnv       :: IdEnv a -> GenId ty -> Maybe a
1884 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1885 \end{code}
1886
1887 \begin{code}
1888 addOneToIdEnv    = addToUFM
1889 combineIdEnvs    = plusUFM_C
1890 delManyFromIdEnv = delListFromUFM
1891 delOneFromIdEnv  = delFromUFM
1892 growIdEnv        = plusUFM
1893 lookupIdEnv      = lookupUFM
1894 mapIdEnv         = mapUFM
1895 mkIdEnv          = listToUFM
1896 nullIdEnv        = emptyUFM
1897 rngIdEnv         = eltsUFM
1898 unitIdEnv        = unitUFM
1899
1900 growIdEnvList     env pairs = plusUFM env (listToUFM pairs)
1901 isNullIdEnv       env       = sizeUFM env == 0
1902 lookupNoFailIdEnv env id    = case (lookupIdEnv env id) of { Just xx -> xx }
1903
1904 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1905 -- modify function, and put it back.
1906
1907 modifyIdEnv env mangle_fn key
1908   = case (lookupIdEnv env key) of
1909       Nothing -> env
1910       Just xx -> addOneToIdEnv env key (mangle_fn xx)
1911 \end{code}
1912
1913 \begin{code}
1914 type GenIdSet ty = UniqSet (GenId ty)
1915 type IdSet       = UniqSet (GenId Type)
1916
1917 emptyIdSet      :: GenIdSet ty
1918 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1919 unionIdSets     :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1920 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1921 idSetToList     :: GenIdSet ty -> [GenId ty]
1922 unitIdSet       :: GenId ty -> GenIdSet ty
1923 addOneToIdSet   :: GenIdSet ty -> GenId ty -> GenIdSet ty
1924 elementOfIdSet  :: GenId ty -> GenIdSet ty -> Bool
1925 minusIdSet      :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1926 isEmptyIdSet    :: GenIdSet ty -> Bool
1927 mkIdSet         :: [GenId ty] -> GenIdSet ty
1928
1929 emptyIdSet      = emptyUniqSet
1930 unitIdSet       = unitUniqSet
1931 addOneToIdSet   = addOneToUniqSet
1932 intersectIdSets = intersectUniqSets
1933 unionIdSets     = unionUniqSets
1934 unionManyIdSets = unionManyUniqSets
1935 idSetToList     = uniqSetToList
1936 elementOfIdSet  = elementOfUniqSet
1937 minusIdSet      = minusUniqSet
1938 isEmptyIdSet    = isEmptyUniqSet
1939 mkIdSet         = mkUniqSet
1940 \end{code}