ghc/compiler/basicTypes/Id.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Id]{@Ids@: Value and constructor identifiers}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Id {- (
  10         GenId, Id(..),          -- Abstract
  11         StrictnessMark(..),     -- An enumaration
  12         ConTag(..), DictVar(..), DictFun(..), DataCon(..),
  13
  14         -- CONSTRUCTION
  15         mkSysLocal, mkUserLocal,
  16         mkSpecPragmaId,
  17         mkSpecId, mkSameSpecCon,
  18         selectIdInfoForSpecId,
  19         mkTemplateLocals,
  20         mkImported, mkPreludeId,
  21         mkDataCon, mkTupleCon,
  22         mkIdWithNewUniq,
  23         mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
  24         mkConstMethodId, getConstMethodId,
  25
  26         updateIdType,
  27         mkId, mkDictFunId, mkInstId,
  28         mkWorkerId,
  29         localiseId,
  30
  31         -- DESTRUCTION
  32         idType,
  33         getIdInfo, replaceIdInfo,
  34         getPragmaInfo,
  35         idPrimRep, getInstIdModule,
  36         getMentionedTyConsAndClassesFromId,
  37
  38         dataConTag, dataConStrictMarks,
  39         dataConSig, dataConArgTys,
  40         dataConTyCon, dataConArity,
  41         dataConFieldLabels,
  42
  43         recordSelectorFieldLabel,
  44
  45         -- PREDICATES
  46         isDataCon, isTupleCon,
  47         isSpecId_maybe, isSpecPragmaId_maybe,
  48         toplevelishId, externallyVisibleId,
  49         isTopLevId, isWorkerId, isWrapperId,
  50         isImportedId, isSysLocalId,
  51         isBottomingId,
  52         isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe,
  53         isDictFunId,
  54 --???   isInstId_maybe,
  55         isConstMethodId_maybe,
  56         cmpId_withSpecDataCon,
  57         myWrapperMaybe,
  58         whatsMentionedInId,
  59         unfoldingUnfriendlyId,  -- ToDo: rm, eventually
  60         idWantsToBeINLINEd,
  61 --      dataConMentionsNonPreludeTyCon,
  62
  63         -- SUBSTITUTION
  64         applySubstToId, applyTypeEnvToId,
  65 -- not exported:        apply_to_Id, -- please don't use this, generally
  66
  67         -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
  68         getIdArity, addIdArity,
  69         getIdDemandInfo, addIdDemandInfo,
  70         getIdSpecialisation, addIdSpecialisation,
  71         getIdStrictness, addIdStrictness,
  72         getIdUnfolding, addIdUnfolding,
  73         getIdUpdateInfo, addIdUpdateInfo,
  74         getIdArgUsageInfo, addIdArgUsageInfo,
  75         getIdFBTypeInfo, addIdFBTypeInfo,
  76         -- don't export the types, lest OptIdInfo be dragged in!
  77
  78         -- MISCELLANEOUS
  79         unlocaliseId,
  80         fIRST_TAG,
  81         showId,
  82         pprIdInUnfolding,
  83
  84         nmbrId,
  85
  86         -- "Environments" keyed off of Ids, and sets of Ids
  87         IdEnv(..),
  88         lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
  89         growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv,
  90         delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs,
  91         rngIdEnv, mapIdEnv,
  92
  93         -- and to make the interface self-sufficient...
  94         GenIdSet(..), IdSet(..)
  95     )-} where
  96
  97 import Ubiq
  98 import IdLoop   -- for paranoia checking
  99 import TyLoop   -- for paranoia checking
 100
 101 import Bag
 102 import Class            ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
 103 import CStrings         ( identToC, cSEP )
 104 import IdInfo
 105 import Maybes           ( maybeToBool )
 106 import Name             ( appendRdr, nameUnique, mkLocalName, isLocalName,
 107                           isLocallyDefinedName, isPreludeDefinedName,
 108                           mkTupleDataConName, mkCompoundName,
 109                           isLexSym, isLexSpecialSym, getLocalName,
 110                           isLocallyDefined, isPreludeDefined,
 111                           getOccName, moduleNamePair, origName, nameOf,
 112                           isExported, ExportFlag(..),
 113                           RdrName(..), Name
 114                         )
 115 import FieldLabel       ( fieldLabelName, FieldLabel(..){-instances-} )
 116 import PragmaInfo       ( PragmaInfo(..) )
 117 import PprEnv           -- ( NmbrM(..), NmbrEnv(..) )
 118 import PprType          ( getTypeString, typeMaybeString, specMaybeTysSuffix,
 119                           nmbrType, nmbrTyVar,
 120                           GenType, GenTyVar
 121                         )
 122 import PprStyle
 123 import Pretty
 124 import SrcLoc           ( mkBuiltinSrcLoc )
 125 import TyCon            ( TyCon, mkTupleTyCon, tyConDataCons )
 126 import Type             ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
 127                           applyTyCon, isPrimType, instantiateTy,
 128                           tyVarsOfType, applyTypeEnvToTy, typePrimRep,
 129                           GenType, ThetaType(..), TauType(..), Type(..)
 130                         )
 131 import TyVar            ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
 132 import UniqFM
 133 import UniqSet          -- practically all of it
 134 import Unique           ( getBuiltinUniques, pprUnique, showUnique,
 135                           incrUnique,
 136                           Unique{-instance Ord3-}
 137                         )
 138 import Util             ( mapAccumL, nOfThem, zipEqual,
 139                           panic, panic#, pprPanic, assertPanic
 140                         )
 141 \end{code}
 142
 143 Here are the @Id@ and @IdDetails@ datatypes; also see the notes that
 144 follow.
 145
 146 Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a
 147 @Type@, and an @IdInfo@ (non-essential info about it, e.g.,
 148 strictness).  The essential info about different kinds of @Ids@ is
 149 in its @IdDetails@.
 150
 151 ToDo: possibly cache other stuff in the single-constructor @Id@ type.
 152
 153 \begin{code}
 154 data GenId ty = Id
 155         Unique          -- Key for fast comparison
 156         ty              -- Id's type; used all the time;
 157         IdDetails       -- Stuff about individual kinds of Ids.
 158         PragmaInfo      -- Properties of this Id requested by programmer
 159                         -- eg specialise-me, inline-me
 160         IdInfo          -- Properties of this Id deduced by compiler
 161
 162 type Id = GenId Type
 163
 164 data StrictnessMark = MarkedStrict | NotMarkedStrict
 165
 166 data IdDetails
 167
 168   ---------------- Local values
 169
 170   = LocalId     Name            -- Local name; mentioned by the user
 171                 Bool            -- True <=> no free type vars
 172
 173   | SysLocalId  Name            -- Local name; made up by the compiler
 174                 Bool            -- as for LocalId
 175
 176   | SpecPragmaId Name           -- Local name; introduced by the compiler
 177                  (Maybe Id)     -- for explicit specid in pragma
 178                  Bool           -- as for LocalId
 179
 180   ---------------- Global values
 181
 182   | ImportedId  Name            -- Global name (Imported or Implicit); Id imported from an interface
 183
 184   | PreludeId   Name            -- Global name (Builtin);  Builtin prelude Ids
 185
 186   | TopLevId    Name            -- Global name (LocalDef); Top-level in the orig source pgm
 187                                 -- (not moved there by transformations).
 188
 189         -- a TopLevId's type may contain free type variables, if
 190         -- the monomorphism restriction applies.
 191
 192   ---------------- Data constructors
 193
 194   | DataConId   Name
 195                 ConTag
 196                 [StrictnessMark] -- Strict args; length = arity
 197                 [FieldLabel]    -- Field labels for this constructor
 198
 199                 [TyVar] [(Class,Type)] [Type] TyCon
 200                                 -- the type is:
 201                                 -- forall tyvars . theta_ty =>
 202                                 --    unitype_1 -> ... -> unitype_n -> tycon tyvars
 203
 204   | TupleConId  Name
 205                 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                 Bool            -- True <=> from an instance decl in this mod
 241                 (Maybe Module)  -- module where instance came from; Nothing => Prelude
 242
 243                                 -- see below
 244   | ConstMethodId               -- A method which depends only on the type of the
 245                                 -- instance, and not on any further dictionaries etc.
 246                 Class           -- Uniquely identified by:
 247                 Type            -- (class, type, classop) triple
 248                 ClassOp
 249                 Bool            -- True => from an instance decl in this mod
 250                 (Maybe Module)  -- module where instance came from; Nothing => Prelude
 251
 252   | InstId      Name            -- An instance of a dictionary, class operation,
 253                                 -- or overloaded value (Local name)
 254                 Bool            -- as for LocalId
 255
 256   | SpecId                      -- A specialisation of another Id
 257                 Id              -- Id of which this is a specialisation
 258                 [Maybe Type]    -- Types at which it is specialised;
 259                                 -- A "Nothing" says this type ain't relevant.
 260                 Bool            -- True <=> no free type vars; it's not enough
 261                                 -- to know about the unspec version, because
 262                                 -- we may specialise to a type w/ free tyvars
 263                                 -- (i.e., in one of the "Maybe Type" dudes).
 264
 265   | WorkerId                    -- A "worker" for some other Id
 266                 Id              -- Id for which this is a worker
 267
 268
 269 type ConTag     = Int
 270 type DictVar    = Id
 271 type DictFun    = Id
 272 type DataCon    = Id
 273 \end{code}
 274
 275
 276 DictFunIds are generated from instance decls.
 277 \begin{verbatim}
 278         class Foo a where
 279           op :: a -> a -> Bool
 280
 281         instance Foo a => Foo [a] where
 282           op = ...
 283 \end{verbatim}
 284 generates the dict fun id decl
 285 \begin{verbatim}
 286         dfun.Foo.[*] = \d -> ...
 287 \end{verbatim}
 288 The dfun id is uniquely named by the (class, type) pair.  Notice, it
 289 isn't a (class,tycon) pair any more, because we may get manually or
 290 automatically generated specialisations of the instance decl:
 291 \begin{verbatim}
 292         instance Foo [Int] where
 293           op = ...
 294 \end{verbatim}
 295 generates
 296 \begin{verbatim}
 297         dfun.Foo.[Int] = ...
 298 \end{verbatim}
 299 The type variables in the name are irrelevant; we print them as stars.
 300
 301
 302 Constant method ids are generated from instance decls where
 303 there is no context; that is, no dictionaries are needed to
 304 construct the method.  Example
 305 \begin{verbatim}
 306         instance Foo Int where
 307           op = ...
 308 \end{verbatim}
 309 Then we get a constant method
 310 \begin{verbatim}
 311         Foo.op.Int = ...
 312 \end{verbatim}
 313
 314 It is possible, albeit unusual, to have a constant method
 315 for an instance decl which has type vars:
 316 \begin{verbatim}
 317         instance Foo [a] where
 318           op []     ys = True
 319           op (x:xs) ys = False
 320 \end{verbatim}
 321 We get the constant method
 322 \begin{verbatim}
 323         Foo.op.[*] = ...
 324 \end{verbatim}
 325 So a constant method is identified by a class/op/type triple.
 326 The type variables in the type are irrelevant.
 327
 328
 329 For Ids whose names must be known/deducible in other modules, we have
 330 to conjure up their worker's names (and their worker's worker's
 331 names... etc) in a known systematic way.
 332
 333
 334 %************************************************************************
 335 %*                                                                      *
 336 \subsection[Id-documentation]{Documentation}
 337 %*                                                                      *
 338 %************************************************************************
 339
 340 [A BIT DATED [WDP]]
 341
 342 The @Id@ datatype describes {\em values}.  The basic things we want to
 343 know: (1)~a value's {\em type} (@idType@ is a very common
 344 operation in the compiler); and (2)~what ``flavour'' of value it might
 345 be---for example, it can be terribly useful to know that a value is a
 346 class method.
 347
 348 \begin{description}
 349 %----------------------------------------------------------------------
 350 \item[@DataConId@:] For the data constructors declared by a @data@
 351 declaration.  Their type is kept in {\em two} forms---as a regular
 352 @Type@ (in the usual place), and also in its constituent pieces (in
 353 the ``details''). We are frequently interested in those pieces.
 354
 355 %----------------------------------------------------------------------
 356 \item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
 357 the infinite family of tuples.
 358
 359 %----------------------------------------------------------------------
 360 \item[@ImportedId@:] These are values defined outside this module.
 361 {\em Everything} we want to know about them must be stored here (or in
 362 their @IdInfo@).
 363
 364 %----------------------------------------------------------------------
 365 \item[@PreludeId@:] ToDo
 366
 367 %----------------------------------------------------------------------
 368 \item[@TopLevId@:] These are values defined at the top-level in this
 369 module; i.e., those which {\em might} be exported (hence, a
 370 @Name@).  It does {\em not} include those which are moved to the
 371 top-level through program transformations.
 372
 373 We also guarantee that @TopLevIds@ will {\em stay} at top-level.
 374 Theoretically, they could be floated inwards, but there's no known
 375 advantage in doing so.  This way, we can keep them with the same
 376 @Unique@ throughout (no cloning), and, in general, we don't have to be
 377 so paranoid about them.
 378
 379 In particular, we had the following problem generating an interface:
 380 We have to ``stitch together'' info (1)~from the typechecker-produced
 381 global-values list (GVE) and (2)~from the STG code [which @Ids@ have
 382 what arities].  If the @Uniques@ on the @TopLevIds@ can {\em change}
 383 between (1) and (2), you're sunk!
 384
 385 %----------------------------------------------------------------------
 386 \item[@MethodSelId@:] A selector from a dictionary; it may select either
 387 a method or a dictionary for one of the class's superclasses.
 388
 389 %----------------------------------------------------------------------
 390 \item[@DictFunId@:]
 391
 392 @mkDictFunId [a,b..] theta C T@ is the function derived from the
 393 instance declaration
 394
 395         instance theta => C (T a b ..) where
 396                 ...
 397
 398 It builds function @Id@ which maps dictionaries for theta,
 399 to a dictionary for C (T a b ..).
 400
 401 *Note* that with the ``Mark Jones optimisation'', the theta may
 402 include dictionaries for the immediate superclasses of C at the type
 403 (T a b ..).
 404
 405 %----------------------------------------------------------------------
 406 \item[@InstId@:]
 407
 408 %----------------------------------------------------------------------
 409 \item[@SpecId@:]
 410
 411 %----------------------------------------------------------------------
 412 \item[@WorkerId@:]
 413
 414 %----------------------------------------------------------------------
 415 \item[@LocalId@:] A purely-local value, e.g., a function argument,
 416 something defined in a @where@ clauses, ... --- but which appears in
 417 the original program text.
 418
 419 %----------------------------------------------------------------------
 420 \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
 421 the original program text; these are introduced by the compiler in
 422 doing its thing.
 423
 424 %----------------------------------------------------------------------
 425 \item[@SpecPragmaId@:] Introduced by the compiler to record
 426 Specialisation pragmas. It is dead code which MUST NOT be removed
 427 before specialisation.
 428 \end{description}
 429
 430 Further remarks:
 431 \begin{enumerate}
 432 %----------------------------------------------------------------------
 433 \item
 434
 435 @DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
 436 @MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
 437 properties:
 438 \begin{itemize}
 439 \item
 440 They have no free type variables, so if you are making a
 441 type-variable substitution you don't need to look inside them.
 442 \item
 443 They are constants, so they are not free variables.  (When the STG
 444 machine makes a closure, it puts all the free variables in the
 445 closure; the above are not required.)
 446 \end{itemize}
 447 Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above
 448 properties, but they may not.
 449 \end{enumerate}
 450
 451 %************************************************************************
 452 %*                                                                      *
 453 \subsection[Id-general-funs]{General @Id@-related functions}
 454 %*                                                                      *
 455 %************************************************************************
 456
 457 \begin{code}
 458 unsafeGenId2Id :: GenId ty -> Id
 459 unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i
 460
 461 isDataCon id = is_data (unsafeGenId2Id id)
 462  where
 463   is_data (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = True
 464   is_data (Id _ _ (TupleConId _ _) _ _)            = True
 465   is_data (Id _ _ (SpecId unspec _ _) _ _)         = is_data unspec
 466   is_data other                                    = False
 467
 468
 469 isTupleCon id = is_tuple (unsafeGenId2Id id)
 470  where
 471   is_tuple (Id _ _ (TupleConId _ _) _ _)         = True
 472   is_tuple (Id _ _ (SpecId unspec _ _) _ _)      = is_tuple unspec
 473   is_tuple other                                 = False
 474
 475 {-LATER:
 476 isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _)
 477   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
 478     Just (unspec, ty_maybes)
 479 isSpecId_maybe other_id
 480   = Nothing
 481
 482 isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _)
 483   = Just specid
 484 isSpecPragmaId_maybe other_id
 485   = Nothing
 486 -}
 487 \end{code}
 488
 489 @toplevelishId@ tells whether an @Id@ {\em may} be defined in a
 490 nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be
 491 defined at top level (returns @True@).  This is used to decide whether
 492 the @Id@ is a candidate free variable.  NB: you are only {\em sure}
 493 about something if it returns @True@!
 494
 495 \begin{code}
 496 toplevelishId       :: Id -> Bool
 497 idHasNoFreeTyVars   :: Id -> Bool
 498
 499 toplevelishId (Id _ _ details _ _)
 500   = chk details
 501   where
 502     chk (DataConId _ _ _ _ _ _ _ _) = True
 503     chk (TupleConId _ _)            = True
 504     chk (RecordSelId _)             = True
 505     chk (ImportedId _)              = True
 506     chk (PreludeId  _)              = True
 507     chk (TopLevId   _)              = True      -- NB: see notes
 508     chk (SuperDictSelId _ _)        = True
 509     chk (MethodSelId _ _)           = True
 510     chk (DefaultMethodId _ _ _)     = True
 511     chk (DictFunId     _ _ _ _)     = True
 512     chk (ConstMethodId _ _ _ _ _)   = True
 513     chk (SpecId unspec _ _)         = toplevelishId unspec
 514                                     -- depends what the unspecialised thing is
 515     chk (WorkerId unwrkr)           = toplevelishId unwrkr
 516     chk (InstId _ _)                = False     -- these are local
 517     chk (LocalId      _ _)          = False
 518     chk (SysLocalId   _ _)          = False
 519     chk (SpecPragmaId _ _ _)        = False
 520
 521 idHasNoFreeTyVars (Id _ _ details _ info)
 522   = chk details
 523   where
 524     chk (DataConId _ _ _ _ _ _ _ _) = True
 525     chk (TupleConId _ _)          = True
 526     chk (RecordSelId _)           = True
 527     chk (ImportedId _)            = True
 528     chk (PreludeId  _)            = True
 529     chk (TopLevId   _)            = True
 530     chk (SuperDictSelId _ _)      = True
 531     chk (MethodSelId _ _)         = True
 532     chk (DefaultMethodId _ _ _)   = True
 533     chk (DictFunId     _ _ _ _)   = True
 534     chk (ConstMethodId _ _ _ _ _) = True
 535     chk (WorkerId unwrkr)         = idHasNoFreeTyVars unwrkr
 536     chk (InstId       _   no_free_tvs) = no_free_tvs
 537     chk (SpecId _     _   no_free_tvs) = no_free_tvs
 538     chk (LocalId      _   no_free_tvs) = no_free_tvs
 539     chk (SysLocalId   _   no_free_tvs) = no_free_tvs
 540     chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs
 541 \end{code}
 542
 543 \begin{code}
 544 isTopLevId (Id _ _ (TopLevId _) _ _) = True
 545 isTopLevId other                     = False
 546
 547 isImportedId (Id _ _ (ImportedId _) _ _) = True
 548 isImportedId other                       = False
 549
 550 isBottomingId (Id _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
 551
 552 isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True
 553 isSysLocalId other                         = False
 554
 555 isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True
 556 isSpecPragmaId other                             = False
 557
 558 isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True
 559 isMethodSelId _                          = False
 560
 561 isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True
 562 isDefaultMethodId other                                = False
 563
 564 isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _)
 565   = Just (cls, clsop, err)
 566 isDefaultMethodId_maybe other = Nothing
 567
 568 isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True
 569 isDictFunId other                            = False
 570
 571 isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True
 572 isConstMethodId other                                  = False
 573
 574 isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _)
 575   = Just (cls, ty, clsop)
 576 isConstMethodId_maybe other = Nothing
 577
 578 isSuperDictSelId_maybe (Id _ _ (SuperDictSelId c sc) _ _) = Just (c, sc)
 579 isSuperDictSelId_maybe other_id                           = Nothing
 580
 581 isWorkerId (Id _ _ (WorkerId _) _ _) = True
 582 isWorkerId other                     = False
 583
 584 {-LATER:
 585 isWrapperId id = workerExists (getIdStrictness id)
 586 -}
 587 \end{code}
 588
 589 \begin{code}
 590 {-LATER:
 591 pprIdInUnfolding :: IdSet -> Id -> Pretty
 592
 593 pprIdInUnfolding in_scopes v
 594   = let
 595         v_ty = idType v
 596     in
 597     -- local vars first:
 598     if v `elementOfUniqSet` in_scopes then
 599         pprUnique (idUnique v)
 600
 601     -- ubiquitous Ids with special syntax:
 602     else if v == nilDataCon then
 603         ppPStr SLIT("_NIL_")
 604     else if isTupleCon v then
 605         ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
 606
 607     -- ones to think about:
 608     else
 609         let
 610             (Id _ _ v_details _ _) = v
 611         in
 612         case v_details of
 613             -- these ones must have been exported by their original module
 614           ImportedId   _ -> pp_full_name
 615           PreludeId    _ -> pp_full_name
 616
 617             -- these ones' exportedness checked later...
 618           TopLevId  _ -> pp_full_name
 619           DataConId _ _ _ _ _ _ _ _ -> pp_full_name
 620
 621           RecordSelId lbl -> ppr sty lbl
 622
 623             -- class-ish things: class already recorded as "mentioned"
 624           SuperDictSelId c sc
 625             -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
 626           MethodSelId c o
 627             -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
 628           DefaultMethodId c o _
 629             -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
 630
 631             -- instance-ish things: should we try to figure out
 632             -- *exactly* which extra instances have to be exported? (ToDo)
 633           DictFunId  c t _ _
 634             -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
 635           ConstMethodId c t o _ _
 636             -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
 637
 638           -- specialisations and workers
 639           SpecId unspec ty_maybes _
 640             -> let
 641                   pp = pprIdInUnfolding in_scopes unspec
 642                in
 643                ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
 644                         ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
 645                         ppRbrack]
 646
 647           WorkerId unwrkr
 648             -> let
 649                   pp = pprIdInUnfolding in_scopes unwrkr
 650                in
 651                ppBeside (ppPStr SLIT("_WRKR_ ")) pp
 652
 653           -- anything else? we're nae interested
 654           other_id -> panic "pprIdInUnfolding:mystery Id"
 655   where
 656     ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
 657
 658     pp_full_name
 659       = let
 660             (m_str, n_str) = moduleNamePair v
 661
 662             pp_n =
 663               if isLexSym n_str && not (isLexSpecialSym n_str) then
 664                   ppBesides [ppLparen, ppPStr n_str, ppRparen]
 665               else
 666                   ppPStr n_str
 667         in
 668         if isPreludeDefined v then
 669             pp_n
 670         else
 671             ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
 672
 673     pp_class :: Class -> Pretty
 674     pp_class_op :: ClassOp -> Pretty
 675     pp_type :: Type -> Pretty
 676     pp_ty_maybe :: Maybe Type -> Pretty
 677
 678     pp_class    clas = ppr ppr_Unfolding clas
 679     pp_class_op op   = ppr ppr_Unfolding op
 680
 681     pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
 682
 683     pp_ty_maybe Nothing  = ppPStr SLIT("_N_")
 684     pp_ty_maybe (Just t) = pp_type t
 685 -}
 686 \end{code}
 687
 688 @whatsMentionedInId@ ferrets out the types/classes/instances on which
 689 this @Id@ depends.  If this Id is to appear in an interface, then
 690 those entities had Jolly Well be in scope.  Someone else up the
 691 call-tree decides that.
 692
 693 \begin{code}
 694 {-LATER:
 695 whatsMentionedInId
 696         :: IdSet                            -- Ids known to be in scope
 697         -> Id                               -- Id being processed
 698         -> (Bag Id, Bag TyCon, Bag Class)   -- mentioned Ids/TyCons/etc.
 699
 700 whatsMentionedInId in_scopes v
 701   = let
 702         v_ty = idType v
 703
 704         (tycons, clss)
 705           = getMentionedTyConsAndClassesFromType v_ty
 706
 707         result0 id_bag = (id_bag, tycons, clss)
 708
 709         result1 ids tcs cs
 710           = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
 711              tcs `unionBags` tycons,
 712              cs  `unionBags` clss)
 713     in
 714     -- local vars first:
 715     if v `elementOfUniqSet` in_scopes then
 716         result0 emptyBag    -- v not added to "mentioned"
 717
 718     -- ones to think about:
 719     else
 720         let
 721             (Id _ _ v_details _ _) = v
 722         in
 723         case v_details of
 724           -- specialisations and workers
 725           SpecId unspec ty_maybes _
 726             -> let
 727                   (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
 728                in
 729                result1 ids2 tcs2 cs2
 730
 731           WorkerId unwrkr
 732             -> let
 733                   (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
 734                in
 735                result1 ids2 tcs2 cs2
 736
 737           anything_else -> result0 (unitBag v) -- v is  added to "mentioned"
 738 -}
 739 \end{code}
 740
 741 Tell them who my wrapper function is.
 742 \begin{code}
 743 {-LATER:
 744 myWrapperMaybe :: Id -> Maybe Id
 745
 746 myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper
 747 myWrapperMaybe other_id                           = Nothing
 748 -}
 749 \end{code}
 750
 751 \begin{code}
 752 unfoldingUnfriendlyId   -- return True iff it is definitely a bad
 753         :: Id           -- idea to export an unfolding that
 754         -> Bool         -- mentions this Id.  Reason: it cannot
 755                         -- possibly be seen in another module.
 756
 757 unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
 758 {-LATER:
 759
 760 unfoldingUnfriendlyId id
 761   | not (externallyVisibleId id) -- that settles that...
 762   = True
 763
 764 unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _)
 765   = class_thing wrapper
 766   where
 767     -- "class thing": If we're going to use this worker Id in
 768     -- an interface, we *have* to be able to untangle the wrapper's
 769     -- strictness when reading it back in.  At the moment, this
 770     -- is not always possible: in precisely those cases where
 771     -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
 772
 773     class_thing (Id _ _ (SuperDictSelId _ _) _ _)    = True
 774     class_thing (Id _ _ (MethodSelId _ _) _ _)             = True
 775     class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True
 776     class_thing other                              = False
 777
 778 unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _)
 779     -- a SPEC of a DictFunId can end up w/ gratuitous
 780     -- TyVar(Templates) in the i/face; only a problem
 781     -- if -fshow-pragma-name-errs; but we can do without the pain.
 782     -- A HACK in any case (WDP 94/05/02)
 783   = naughty_DictFunId dfun
 784
 785 unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _)
 786   = naughty_DictFunId dfun -- similar deal...
 787
 788 unfoldingUnfriendlyId other_id   = False -- is friendly in all other cases
 789
 790 naughty_DictFunId :: IdDetails -> Bool
 791     -- True <=> has a TyVar(Template) in the "type" part of its "name"
 792
 793 naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
 794 naughty_DictFunId (DictFunId _ ty _ _)
 795   = not (isGroundTy ty)
 796 -}
 797 \end{code}
 798
 799 @externallyVisibleId@: is it true that another module might be
 800 able to ``see'' this Id?
 801
 802 We need the @toplevelishId@ check as well as @isExported@ for when we
 803 compile instance declarations in the prelude.  @DictFunIds@ are
 804 ``exported'' if either their class or tycon is exported, but, in
 805 compiling the prelude, the compiler may not recognise that as true.
 806
 807 \begin{code}
 808 externallyVisibleId :: Id -> Bool
 809
 810 externallyVisibleId id@(Id _ _ details _ _)
 811   = if isLocallyDefined id then
 812         toplevelishId id && isExported id && not (weird_datacon details)
 813     else
 814         not (weird_tuplecon details)
 815         -- if visible here, it must be visible elsewhere, too.
 816   where
 817     -- If it's a DataCon, it's not enough to know it (meaning
 818     -- its TyCon) is exported; we need to know that it might
 819     -- be visible outside.  Consider:
 820     --
 821     --  data Foo a = Mumble | BigFoo a WeirdLocalType
 822     --
 823     -- We can't tell the outside world *anything* about Foo, because
 824     -- of WeirdLocalType; but we need to know this when asked if
 825     -- "Mumble" is externally visible...
 826
 827 {- LATER: if at all:
 828     weird_datacon (DataConId _ _ _ _ _ _ _ tycon)
 829       = maybeToBool (maybePurelyLocalTyCon tycon)
 830 -}
 831     weird_datacon not_a_datacon_therefore_not_weird = False
 832
 833     weird_tuplecon (TupleConId _ arity)
 834       = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
 835     weird_tuplecon _ = False
 836 \end{code}
 837
 838 \begin{code}
 839 idWantsToBeINLINEd :: Id -> Bool
 840
 841 idWantsToBeINLINEd (Id _ _ _ IWantToBeINLINEd _) = True
 842 idWantsToBeINLINEd _                             = False
 843 \end{code}
 844
 845 For @unlocaliseId@: See the brief commentary in
 846 \tr{simplStg/SimplStg.lhs}.
 847
 848 \begin{code}
 849 {-LATER:
 850 unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
 851
 852 unlocaliseId mod (Id u ty info (TopLevId fn))
 853   = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
 854
 855 unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
 856   = --false?: ASSERT(no_ftvs)
 857     let
 858         full_name = unlocaliseShortName mod u sn
 859     in
 860     Just (Id u ty info (TopLevId full_name))
 861
 862 unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
 863   = --false?: on PreludeGlaST: ASSERT(no_ftvs)
 864     let
 865         full_name = unlocaliseShortName mod u sn
 866     in
 867     Just (Id u ty info (TopLevId full_name))
 868
 869 unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
 870   = case unlocalise_parent mod u unspec of
 871       Nothing -> Nothing
 872       Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))
 873
 874 unlocaliseId mod (Id u ty info (WorkerId unwrkr))
 875   = case unlocalise_parent mod u unwrkr of
 876       Nothing -> Nothing
 877       Just xx -> Just (Id u ty info (WorkerId xx))
 878
 879 unlocaliseId mod (Id u ty info (InstId name no_ftvs))
 880   = Just (Id u ty info (TopLevId full_name))
 881         -- type might be wrong, but it hardly matters
 882         -- at this stage (just before printing C)  ToDo
 883   where
 884     name = getLocalName name
 885     full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
 886
 887 unlocaliseId mod other_id = Nothing
 888
 889 --------------------
 890 -- we have to be Very Careful for workers/specs of
 891 -- local functions!
 892
 893 unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs))
 894   = --false?: ASSERT(no_ftvs)
 895     let
 896         full_name = unlocaliseShortName mod uniq sn
 897     in
 898     Just (Id uniq ty info (TopLevId full_name))
 899
 900 unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
 901   = --false?: ASSERT(no_ftvs)
 902     let
 903         full_name = unlocaliseShortName mod uniq sn
 904     in
 905     Just (Id uniq ty info (TopLevId full_name))
 906
 907 unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
 908   -- we're OK otherwise
 909 -}
 910 \end{code}
 911
 912 CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
 913 `Top-levelish Ids'' cannot have any free type variables, so applying
 914 the type-env cannot have any effect.  (NB: checked in CoreLint?)
 915
 916 The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the
 917 former ``should be'' the usual crunch point.
 918
 919 \begin{code}
 920 type TypeEnv = TyVarEnv Type
 921
 922 applyTypeEnvToId :: TypeEnv -> Id -> Id
 923
 924 applyTypeEnvToId type_env id@(Id _ ty _ _ _)
 925   | idHasNoFreeTyVars id
 926   = id
 927   | otherwise
 928   = apply_to_Id ( \ ty ->
 929         applyTypeEnvToTy type_env ty
 930     ) id
 931 \end{code}
 932
 933 \begin{code}
 934 apply_to_Id :: (Type -> Type)
 935             -> Id
 936             -> Id
 937
 938 apply_to_Id ty_fn (Id u ty details prag info)
 939   = let
 940         new_ty = ty_fn ty
 941     in
 942     Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info)
 943   where
 944     apply_to_details (SpecId unspec ty_maybes no_ftvs)
 945       = let
 946             new_unspec = apply_to_Id ty_fn unspec
 947             new_maybes = map apply_to_maybe ty_maybes
 948         in
 949         SpecId new_unspec new_maybes (no_free_tvs ty)
 950         -- ToDo: gratuitous recalc no_ftvs???? (also InstId)
 951       where
 952         apply_to_maybe Nothing   = Nothing
 953         apply_to_maybe (Just ty) = Just (ty_fn ty)
 954
 955     apply_to_details (WorkerId unwrkr)
 956       = let
 957             new_unwrkr = apply_to_Id ty_fn unwrkr
 958         in
 959         WorkerId new_unwrkr
 960
 961     apply_to_details other = other
 962 \end{code}
 963
 964 Sadly, I don't think the one using the magic typechecker substitution
 965 can be done with @apply_to_Id@.  Here we go....
 966
 967 Strictness is very important here.  We can't leave behind thunks
 968 with pointers to the substitution: it {\em must} be single-threaded.
 969
 970 \begin{code}
 971 {-LATER:
 972 applySubstToId :: Subst -> Id -> (Subst, Id)
 973
 974 applySubstToId subst id@(Id u ty info details)
 975   -- *cannot* have a "idHasNoFreeTyVars" get-out clause
 976   -- because, in the typechecker, we are still
 977   -- *concocting* the types.
 978   = case (applySubstToTy     subst ty)          of { (s2, new_ty)      ->
 979     case (applySubstToIdInfo s2    info)        of { (s3, new_info)    ->
 980     case (apply_to_details   s3 new_ty details) of { (s4, new_details) ->
 981     (s4, Id u new_ty new_info new_details) }}}
 982   where
 983     apply_to_details subst _ (InstId inst no_ftvs)
 984       = case (applySubstToInst subst inst) of { (s2, new_inst) ->
 985         (s2, InstId new_inst no_ftvs{-ToDo:right???-}) }
 986
 987     apply_to_details subst new_ty (SpecId unspec ty_maybes _)
 988       = case (applySubstToId subst unspec)           of { (s2, new_unspec) ->
 989         case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) ->
 990         (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }}
 991         -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04)
 992       where
 993         apply_to_maybe subst Nothing   = (subst, Nothing)
 994         apply_to_maybe subst (Just ty)
 995           = case (applySubstToTy subst ty) of { (s2, new_ty) ->
 996             (s2, Just new_ty) }
 997
 998     apply_to_details subst _ (WorkerId unwrkr)
 999       = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) ->
1000         (s2, WorkerId new_unwrkr) }
1001
1002     apply_to_details subst _ other = (subst, other)
1003 -}
1004 \end{code}
1005
1006 \begin{code}
1007 getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING]
1008
1009 getIdNamePieces show_uniqs id
1010   = get (unsafeGenId2Id id)
1011   where
1012   get (Id u _ details _ _)
1013     = case details of
1014       DataConId n _ _ _ _ _ _ _ ->
1015         case (moduleNamePair n) of { (mod, name) ->
1016         if isPreludeDefinedName n then [name] else [mod, name] }
1017
1018       TupleConId n _ -> [nameOf (origName n)]
1019
1020       RecordSelId lbl ->
1021         let n = fieldLabelName lbl
1022         in
1023         case (moduleNamePair n) of { (mod, name) ->
1024         if isPreludeDefinedName n then [name] else [mod, name] }
1025
1026       ImportedId n -> get_fullname_pieces n
1027       PreludeId  n -> get_fullname_pieces n
1028       TopLevId   n -> get_fullname_pieces n
1029
1030       SuperDictSelId c sc ->
1031         case (moduleNamePair c) of { (c_mod, c_name) ->
1032         case (moduleNamePair sc)        of { (sc_mod, sc_name) ->
1033         let
1034             c_bits = if isPreludeDefined c
1035                      then [c_name]
1036                      else [c_mod, c_name]
1037
1038             sc_bits= if isPreludeDefined sc
1039                      then [sc_name]
1040                      else [sc_mod, sc_name]
1041         in
1042         [SLIT("sdsel")] ++ c_bits ++ sc_bits  }}
1043
1044       MethodSelId clas op ->
1045         case (moduleNamePair clas)      of { (c_mod, c_name) ->
1046         case (classOpString op) of { op_name ->
1047         if isPreludeDefined clas
1048         then [op_name]
1049         else [c_mod, c_name, op_name]
1050         } }
1051
1052       DefaultMethodId clas op _ ->
1053         case (moduleNamePair clas)              of { (c_mod, c_name) ->
1054         case (classOpString op) of { op_name ->
1055         if isPreludeDefined clas
1056         then [SLIT("defm"), op_name]
1057         else [SLIT("defm"), c_mod, c_name, op_name] }}
1058
1059       DictFunId c ty _ _ ->
1060         case (moduleNamePair c)     of { (c_mod, c_name) ->
1061         let
1062             c_bits = if isPreludeDefined c
1063                      then [c_name]
1064                      else [c_mod, c_name]
1065
1066             ty_bits = getTypeString ty
1067         in
1068         [SLIT("dfun")] ++ c_bits ++ ty_bits }
1069
1070       ConstMethodId c ty o _ _ ->
1071         case (moduleNamePair c)     of { (c_mod, c_name) ->
1072         case (getTypeString ty)     of { ty_bits ->
1073         case (classOpString o)   of { o_name ->
1074         case (if isPreludeDefined c
1075               then [c_name]
1076               else [c_mod, c_name]) of { c_bits ->
1077         [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
1078
1079       -- if the unspecialised equiv is "top-level",
1080       -- the name must be concocted from its name and the
1081       -- names of the types to which specialised...
1082
1083       SpecId unspec ty_maybes _ ->
1084         get unspec ++ (if not (toplevelishId unspec)
1085                        then [showUnique u]
1086                        else concat (map typeMaybeString ty_maybes))
1087
1088       WorkerId unwrkr ->
1089         get unwrkr ++ (if not (toplevelishId unwrkr)
1090                        then [showUnique u]
1091                        else [SLIT("wrk")])
1092
1093       LocalId      n _   -> let local = getLocalName n in
1094                             if show_uniqs then [local, showUnique u] else [local]
1095       InstId       n _   -> [getLocalName n, showUnique u]
1096       SysLocalId   n _   -> [getLocalName n, showUnique u]
1097       SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
1098
1099 get_fullname_pieces :: Name -> [FAST_STRING]
1100 get_fullname_pieces n
1101   = case (moduleNamePair n) of { (mod, name) ->
1102     if isPreludeDefinedName n
1103     then [name]
1104     else [mod, name] }
1105 \end{code}
1106
1107 %************************************************************************
1108 %*                                                                      *
1109 \subsection[Id-type-funs]{Type-related @Id@ functions}
1110 %*                                                                      *
1111 %************************************************************************
1112
1113 \begin{code}
1114 idType :: GenId ty -> ty
1115
1116 idType (Id _ ty _ _ _) = ty
1117 \end{code}
1118
1119 \begin{code}
1120 {-LATER:
1121 getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
1122
1123 getMentionedTyConsAndClassesFromId id
1124  = getMentionedTyConsAndClassesFromType (idType id)
1125 -}
1126 \end{code}
1127
1128 \begin{code}
1129 idPrimRep i = typePrimRep (idType i)
1130 \end{code}
1131
1132 \begin{code}
1133 {-LATER:
1134 getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
1135 getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
1136 getInstIdModule other = panic "Id:getInstIdModule"
1137 -}
1138 \end{code}
1139
1140 %************************************************************************
1141 %*                                                                      *
1142 \subsection[Id-overloading]{Functions related to overloading}
1143 %*                                                                      *
1144 %************************************************************************
1145
1146 \begin{code}
1147 mkSuperDictSelId  u c sc     ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
1148 mkMethodSelId     u c op     ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
1149 mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
1150
1151 mkDictFunId u c ity full_ty from_here mod info
1152   = Id u full_ty (DictFunId c ity from_here mod) NoPragmaInfo info
1153
1154 mkConstMethodId u c op ity full_ty from_here mod info
1155   = Id u full_ty (ConstMethodId c ity op from_here mod) NoPragmaInfo info
1156
1157 mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
1158
1159 mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo
1160
1161 {-LATER:
1162 getConstMethodId clas op ty
1163   = -- constant-method info is hidden in the IdInfo of
1164     -- the class-op id (as mentioned up above).
1165     let
1166         sel_id = getMethodSelId clas op
1167     in
1168     case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of
1169       Just xx -> xx
1170       Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [
1171         ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids,
1172                ppr PprDebug sel_id],
1173         ppStr "(This can arise if an interface pragma refers to an instance",
1174         ppStr "but there is no imported interface which *defines* that instance.",
1175         ppStr "The info above, however ugly, should indicate what else you need to import."
1176         ])
1177 -}
1178 \end{code}
1179
1180 %************************************************************************
1181 %*                                                                      *
1182 \subsection[local-funs]{@LocalId@-related functions}
1183 %*                                                                      *
1184 %************************************************************************
1185
1186 \begin{code}
1187 mkImported  n ty info = Id (nameUnique n) ty (ImportedId n) NoPragmaInfo info
1188 mkPreludeId n ty info = Id (nameUnique n) ty (PreludeId  n) NoPragmaInfo info
1189
1190 {-LATER:
1191 updateIdType :: Id -> Type -> Id
1192 updateIdType (Id u _ info details) ty = Id u ty info details
1193 -}
1194 \end{code}
1195
1196 \begin{code}
1197 type MyTy a b = GenType (GenTyVar a) b
1198 type MyId a b = GenId (MyTy a b)
1199
1200 no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
1201
1202 -- SysLocal: for an Id being created by the compiler out of thin air...
1203 -- UserLocal: an Id with a name the user might recognize...
1204 mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
1205
1206 mkSysLocal str uniq ty loc
1207   = Id uniq ty (SysLocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1208
1209 mkUserLocal str uniq ty loc
1210   = Id uniq ty (LocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
1211
1212 -- mkUserId builds a local or top-level Id, depending on the name given
1213 mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
1214 mkUserId name ty pragma_info
1215   | isLocalName name
1216   = Id (nameUnique name) ty (LocalId name (no_free_tvs ty)) pragma_info noIdInfo
1217   | otherwise
1218   = Id (nameUnique name) ty
1219        (if isLocallyDefinedName name then TopLevId name else ImportedId name)
1220         pragma_info noIdInfo
1221 \end{code}
1222
1223
1224 \begin{code}
1225 {-LATER:
1226
1227 -- for a SpecPragmaId being created by the compiler out of thin air...
1228 mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
1229 mkSpecPragmaId str uniq ty specid loc
1230   = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty))
1231
1232 -- for new SpecId
1233 mkSpecId u unspec ty_maybes ty info
1234   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1235     Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty))
1236
1237 -- Specialised version of constructor: only used in STG and code generation
1238 -- Note: The specialsied Id has the same unique as the unspeced Id
1239
1240 mkSameSpecCon ty_maybes unspec@(Id u ty info details)
1241   = ASSERT(isDataCon unspec)
1242     ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1243     Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty))
1244   where
1245     new_ty = specialiseTy ty ty_maybes 0
1246
1247 localiseId :: Id -> Id
1248 localiseId id@(Id u ty info details)
1249   = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
1250   where
1251     name = getOccName id
1252     loc  = getSrcLoc id
1253 -}
1254
1255 mkIdWithNewUniq :: Id -> Unique -> Id
1256
1257 mkIdWithNewUniq (Id _ ty details prag info) uniq
1258   = Id uniq ty details prag info
1259 \end{code}
1260
1261 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
1262 @Uniques@, but that's OK because the templates are supposed to be
1263 instantiated before use.
1264 \begin{code}
1265 mkTemplateLocals :: [Type] -> [Id]
1266 mkTemplateLocals tys
1267   = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
1268             (getBuiltinUniques (length tys))
1269             tys
1270 \end{code}
1271
1272 \begin{code}
1273 getIdInfo     :: GenId ty -> IdInfo
1274 getPragmaInfo :: GenId ty -> PragmaInfo
1275
1276 getIdInfo     (Id _ _ _ _ info) = info
1277 getPragmaInfo (Id _ _ _ info _) = info
1278
1279 {-LATER:
1280 replaceIdInfo :: Id -> IdInfo -> Id
1281
1282 replaceIdInfo (Id u ty _ details) info = Id u ty info details
1283
1284 selectIdInfoForSpecId :: Id -> IdInfo
1285 selectIdInfoForSpecId unspec
1286   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
1287     noIdInfo `addInfo_UF` getIdUnfolding unspec
1288 -}
1289 \end{code}
1290
1291 %************************************************************************
1292 %*                                                                      *
1293 \subsection[Id-arities]{Arity-related functions}
1294 %*                                                                      *
1295 %************************************************************************
1296
1297 For locally-defined Ids, the code generator maintains its own notion
1298 of their arities; so it should not be asking...  (but other things
1299 besides the code-generator need arity info!)
1300
1301 \begin{code}
1302 getIdArity :: Id -> ArityInfo
1303 getIdArity (Id _ _ _ _ id_info)  = getInfo id_info
1304
1305 dataConArity :: DataCon -> Int
1306 dataConArity id@(Id _ _ _ _ id_info)
1307   = ASSERT(isDataCon id)
1308     case (arityMaybe (getInfo id_info)) of
1309       Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
1310       Just  i -> i
1311
1312 addIdArity :: Id -> Int -> Id
1313 addIdArity (Id u ty details pinfo info) arity
1314   = Id u ty details pinfo (info `addInfo` (mkArityInfo arity))
1315 \end{code}
1316
1317 %************************************************************************
1318 %*                                                                      *
1319 \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
1320 %*                                                                      *
1321 %************************************************************************
1322
1323 \begin{code}
1324 mkDataCon :: Name
1325           -> [StrictnessMark] -> [FieldLabel]
1326           -> [TyVar] -> ThetaType -> [TauType] -> TyCon
1327 --ToDo:   -> SpecEnv
1328           -> Id
1329   -- can get the tag and all the pieces of the type from the Type
1330
1331 mkDataCon n stricts fields tvs ctxt args_tys tycon
1332   = ASSERT(length stricts == length args_tys)
1333     data_con
1334   where
1335     -- NB: data_con self-recursion; should be OK as tags are not
1336     -- looked at until late in the game.
1337     data_con
1338       = Id (nameUnique n)
1339            type_of_constructor
1340            (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon)
1341            NoPragmaInfo
1342            datacon_info
1343
1344     data_con_tag    = position_within fIRST_TAG data_con_family
1345
1346     data_con_family = tyConDataCons tycon
1347
1348     position_within :: Int -> [Id] -> Int
1349
1350     position_within acc (c:cs)
1351       = if c == data_con then acc else position_within (acc+1) cs
1352 #ifdef DEBUG
1353     position_within acc []
1354       = panic "mkDataCon: con not found in family"
1355 #endif
1356
1357     type_of_constructor
1358       = mkSigmaTy tvs ctxt
1359         (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
1360
1361     datacon_info = noIdInfo `addInfo_UF` unfolding
1362                             `addInfo` mkArityInfo arity
1363 --ToDo:                     `addInfo` specenv
1364
1365     arity = length args_tys
1366
1367     unfolding
1368       = noInfo_UF
1369 {- LATER:
1370       = -- if arity == 0
1371         -- then noIdInfo
1372         -- else -- do some business...
1373         let
1374             (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
1375             tyvar_tys = mkTyVarTys tyvars
1376         in
1377         case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
1378
1379         mkUnfolding EssentialUnfolding -- for data constructors
1380                     (mkLam tyvars (dict_vars ++ vars) plain_Con)
1381         }
1382
1383     mk_uf_bits tvs ctxt arg_tys tycon
1384       = let
1385             (inst_env, tyvars, tyvar_tys)
1386               = instantiateTyVarTemplates tvs
1387                                           (map uniqueOf tvs)
1388         in
1389             -- the "context" and "arg_tys" have TyVarTemplates in them, so
1390             -- we instantiate those types to have the right TyVars in them
1391             -- instead.
1392         case (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
1393                                                         of { inst_dict_tys ->
1394         case (map (instantiateTauTy inst_env) arg_tys)  of { inst_arg_tys ->
1395
1396             -- We can only have **ONE** call to mkTemplateLocals here;
1397             -- otherwise, we get two blobs of locals w/ mixed-up Uniques
1398             -- (Mega-Sigh) [ToDo]
1399         case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars ->
1400
1401         case (splitAt (length ctxt) all_vars)   of { (dict_vars, vars) ->
1402
1403         (tyvars, dict_vars, vars)
1404         }}}}
1405       where
1406         -- these are really dubious Types, but they are only to make the
1407         -- binders for the lambdas for tossed-away dicts.
1408         ctxt_ty (clas, ty) = mkDictTy clas ty
1409 -}
1410 \end{code}
1411
1412 \begin{code}
1413 mkTupleCon :: Arity -> Id
1414
1415 mkTupleCon arity
1416   = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info
1417   where
1418     n           = mkTupleDataConName arity
1419     unique      = uniqueOf n
1420     ty          = mkSigmaTy tyvars []
1421                    (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
1422     tycon       = mkTupleTyCon arity
1423     tyvars      = take arity alphaTyVars
1424     tyvar_tys   = mkTyVarTys tyvars
1425
1426     tuplecon_info
1427       = noIdInfo `addInfo_UF` unfolding
1428                  `addInfo` mkArityInfo arity
1429 --LATER:?        `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
1430
1431     unfolding
1432       = noInfo_UF
1433 {- LATER:
1434       = -- if arity == 0
1435         -- then noIdInfo
1436         -- else -- do some business...
1437         let
1438             (tyvars, dict_vars, vars) = mk_uf_bits arity
1439             tyvar_tys = mkTyVarTys tyvars
1440         in
1441         case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
1442         mkUnfolding
1443             EssentialUnfolding    -- data constructors
1444             (mkLam tyvars (dict_vars ++ vars) plain_Con) }
1445
1446     mk_uf_bits arity
1447       = case (mkTemplateLocals tyvar_tys) of { vars ->
1448         (tyvars, [], vars) }
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           = case moduleNamePair unspec        of { (mod, unspec_nm) ->
1824             case specMaybeTysSuffix ty_maybes of { tys_suffix ->
1825             (mod,
1826              unspec_nm _APPEND_
1827                 (if not (toplevelishId unspec)
1828                  then showUnique u
1829                  else tys_suffix)
1830             ) }}
1831
1832         get (WorkerId unwrkr)
1833           = case moduleNamePair unwrkr  of { (mod, unwrkr_nm) ->
1834             (mod,
1835              unwrkr_nm _APPEND_
1836                 (if not (toplevelishId unwrkr)
1837                  then showUnique u
1838                  else SLIT(".wrk"))
1839             ) }
1840
1841         get other_details
1842             -- the remaining internally-generated flavours of
1843             -- Ids really do not have meaningful "original name" stuff,
1844             -- but we need to make up something (usually for debugging output)
1845
1846           = case (getIdNamePieces True this_id)  of { (piece1:pieces) ->
1847             case [ _CONS_ '.' p | p <- pieces ]  of { dotted_pieces ->
1848             (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) }}
1849 -}
1850 \end{code}
1851
1852 Note: The code generator doesn't carry a @UniqueSupply@, so it uses
1853 the @Uniques@ out of local @Ids@ given to it.
1854
1855 %************************************************************************
1856 %*                                                                      *
1857 \subsection{@IdEnv@s and @IdSet@s}
1858 %*                                                                      *
1859 %************************************************************************
1860
1861 \begin{code}
1862 type IdEnv elt = UniqFM elt
1863
1864 nullIdEnv         :: IdEnv a
1865
1866 mkIdEnv           :: [(GenId ty, a)] -> IdEnv a
1867 unitIdEnv         :: GenId ty -> a -> IdEnv a
1868 addOneToIdEnv     :: IdEnv a -> GenId ty -> a -> IdEnv a
1869 growIdEnv         :: IdEnv a -> IdEnv a -> IdEnv a
1870 growIdEnvList     :: IdEnv a -> [(GenId ty, a)] -> IdEnv a
1871
1872 delManyFromIdEnv  :: IdEnv a -> [GenId ty] -> IdEnv a
1873 delOneFromIdEnv   :: IdEnv a -> GenId ty -> IdEnv a
1874 combineIdEnvs     :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
1875 mapIdEnv          :: (a -> b) -> IdEnv a -> IdEnv b
1876 modifyIdEnv       :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
1877 rngIdEnv          :: IdEnv a -> [a]
1878
1879 isNullIdEnv       :: IdEnv a -> Bool
1880 lookupIdEnv       :: IdEnv a -> GenId ty -> Maybe a
1881 lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a
1882 \end{code}
1883
1884 \begin{code}
1885 addOneToIdEnv    = addToUFM
1886 combineIdEnvs    = plusUFM_C
1887 delManyFromIdEnv = delListFromUFM
1888 delOneFromIdEnv  = delFromUFM
1889 growIdEnv        = plusUFM
1890 lookupIdEnv      = lookupUFM
1891 mapIdEnv         = mapUFM
1892 mkIdEnv          = listToUFM
1893 nullIdEnv        = emptyUFM
1894 rngIdEnv         = eltsUFM
1895 unitIdEnv        = unitUFM
1896
1897 growIdEnvList     env pairs = plusUFM env (listToUFM pairs)
1898 isNullIdEnv       env       = sizeUFM env == 0
1899 lookupNoFailIdEnv env id    = case (lookupIdEnv env id) of { Just xx -> xx }
1900
1901 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
1902 -- modify function, and put it back.
1903
1904 modifyIdEnv env mangle_fn key
1905   = case (lookupIdEnv env key) of
1906       Nothing -> env
1907       Just xx -> addOneToIdEnv env key (mangle_fn xx)
1908 \end{code}
1909
1910 \begin{code}
1911 type GenIdSet ty = UniqSet (GenId ty)
1912 type IdSet       = UniqSet (GenId Type)
1913
1914 emptyIdSet      :: GenIdSet ty
1915 intersectIdSets :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1916 unionIdSets     :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1917 unionManyIdSets :: [GenIdSet ty] -> GenIdSet ty
1918 idSetToList     :: GenIdSet ty -> [GenId ty]
1919 unitIdSet       :: GenId ty -> GenIdSet ty
1920 addOneToIdSet   :: GenIdSet ty -> GenId ty -> GenIdSet ty
1921 elementOfIdSet  :: GenId ty -> GenIdSet ty -> Bool
1922 minusIdSet      :: GenIdSet ty -> GenIdSet ty -> GenIdSet ty
1923 isEmptyIdSet    :: GenIdSet ty -> Bool
1924 mkIdSet         :: [GenId ty] -> GenIdSet ty
1925
1926 emptyIdSet      = emptyUniqSet
1927 unitIdSet       = unitUniqSet
1928 addOneToIdSet   = addOneToUniqSet
1929 intersectIdSets = intersectUniqSets
1930 unionIdSets     = unionUniqSets
1931 unionManyIdSets = unionManyUniqSets
1932 idSetToList     = uniqSetToList
1933 elementOfIdSet  = elementOfUniqSet
1934 minusIdSet      = minusUniqSet
1935 isEmptyIdSet    = isEmptyUniqSet
1936 mkIdSet         = mkUniqSet
1937 \end{code}
1938
1939 \begin{code}
1940 addId, nmbrId :: Id -> NmbrM Id
1941
1942 addId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1943   = case (lookupUFM_Directly idenv u) of
1944       Just xx -> _trace "addId: already in map!" $
1945                  (nenv, xx)
1946       Nothing ->
1947         if toplevelishId id then
1948             _trace "addId: can't add toplevelish!" $
1949             (nenv, id)
1950         else -- alloc a new unique for this guy
1951              -- and add an entry in the idenv
1952              -- NB: *** KNOT-TYING ***
1953             let
1954                 nenv_plus_id    = NmbrEnv (incrUnique ui) ut uu
1955                                           (addToUFM_Directly idenv u new_id)
1956                                           tvenv uvenv
1957
1958                 (nenv2, new_ty)  = nmbrType     ty  nenv_plus_id
1959                 (nenv3, new_det) = nmbr_details det nenv2
1960
1961                 new_id = Id ui new_ty new_det prag info
1962             in
1963             (nenv3, new_id)
1964
1965 nmbrId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
1966   = case (lookupUFM_Directly idenv u) of
1967       Just xx -> (nenv, xx)
1968       Nothing ->
1969         if not (toplevelishId id) then
1970             _trace "nmbrId: lookup failed" $
1971             (nenv, id)
1972         else
1973             let
1974                 (nenv2, new_ty)  = nmbrType     ty  nenv
1975                 (nenv3, new_det) = nmbr_details det nenv2
1976
1977                 new_id = Id u new_ty new_det prag info
1978             in
1979             (nenv3, new_id)
1980
1981 ------------
1982 nmbr_details :: IdDetails -> NmbrM IdDetails
1983
1984 nmbr_details (DataConId n tag marks fields tvs theta arg_tys tc)
1985   = mapNmbr nmbrTyVar  tvs      `thenNmbr` \ new_tvs ->
1986     mapNmbr nmbrField  fields   `thenNmbr` \ new_fields ->
1987     mapNmbr nmbr_theta theta    `thenNmbr` \ new_theta ->
1988     mapNmbr nmbrType   arg_tys  `thenNmbr` \ new_arg_tys ->
1989     returnNmbr (DataConId n tag marks new_fields new_tvs new_theta new_arg_tys tc)
1990   where
1991     nmbr_theta (c,t)
1992       = --nmbrClass c   `thenNmbr` \ new_c ->
1993         nmbrType  t     `thenNmbr` \ new_t ->
1994         returnNmbr (c, new_t)
1995
1996     -- ToDo:add more cases as needed
1997 nmbr_details other_details = returnNmbr other_details
1998
1999 ------------
2000 nmbrField (FieldLabel n ty tag)
2001   = nmbrType ty `thenNmbr` \ new_ty ->
2002     returnNmbr (FieldLabel n new_ty tag)
2003 \end{code}