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